diff options
360 files changed, 15558 insertions, 7444 deletions
diff --git a/.clang-format b/.clang-format new file mode 100644 index 00000000000..7895ada36da --- /dev/null +++ b/.clang-format @@ -0,0 +1,27 @@ +Language: Cpp +BasedOnStyle: LLVM +AlignEscapedNewlinesLeft: true +AlwaysBreakAfterReturnType: TopLevelDefinitions +BreakBeforeBinaryOperators: All +BreakBeforeBraces: GNU +ColumnLimit: 80 +ContinuationIndentWidth: 2 +ForEachMacros: [FOR_EACH_TAIL, FOR_EACH_TAIL_SAFE] +IncludeCategories: + - Regex: '^<config\.h>$' + Priority: -1 + - Regex: '^<' + Priority: 1 + - Regex: '^"lisp\.h"$' + Priority: 2 + - Regex: '.*' + Priority: 3 +KeepEmptyLinesAtTheStartOfBlocks: false +MaxEmptyLinesToKeep: 1 +PenaltyBreakBeforeFirstCallParameter: 2000 +SpaceAfterCStyleCast: true +SpaceBeforeParens: Always + +# Local Variables: +# mode: yaml +# End: diff --git a/Makefile.in b/Makefile.in index 89277e2d66a..009c51a291d 100644 --- a/Makefile.in +++ b/Makefile.in @@ -1155,3 +1155,13 @@ check-declare: exit 1; \ fi $(MAKE) -C lisp $@ + +.PHONY: gitmerge + +GITMERGE_EMACS = ./src/emacs${EXEEXT} +GITMERGE_NMIN = 10 + +gitmerge: + ${GITMERGE_EMACS} -batch --no-site-file --no-site-lisp \ + -l ${srcdir}/admin/gitmerge.el \ + --eval '(setq gitmerge-minimum-missing ${GITMERGE_NMIN})' -f gitmerge @@ -2,7 +2,7 @@ Copyright (C) 2001-2018 Free Software Foundation, Inc. See the end of the file for license conditions. -This directory tree holds version 26.0.90 of GNU Emacs, the extensible, +This directory tree holds version 27.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 7a90b3dbe4f..04d1ff76f36 100644 --- a/admin/CPP-DEFINES +++ b/admin/CPP-DEFINES @@ -19,7 +19,6 @@ __DJGPP_MINOR__ Minor version number of the DJGPP library; used only in msdos.c DOS_NT Compiling for either the MS-DOS or native MS-Windows port. WINDOWSNT Compiling the native MS-Windows (W32) port. __MINGW32__ Compiling the W32 port with the MinGW or MinGW-w64 ports of GCC. -_MSC_VER Compiling the W32 port with the Microsoft C compiler. MINGW_W64 Compiling the W32 port with the MinGW-w64 port of GCC. DARWIN_OS Compiling on macOS or pure Darwin (and using s/darwin.h). SOLARIS2 diff --git a/admin/authors.el b/admin/authors.el index be4cd77fa9e..5032b57fd92 100644 --- a/admin/authors.el +++ b/admin/authors.el @@ -51,17 +51,13 @@ files.") ("Aurélien Aptel" "Aurelien Aptel") ("Barry A. Warsaw" "Barry A. Warsaw, Century Computing, Inc." "Barry A. Warsaw, ITB" "Barry Warsaw") - ("Bastien Guerry" "Bastien") ("Bill Carpenter" "WJ Carpenter") ("Bill Mann" "William F. Mann") ("Bill Rozas" "Guillermo J. Rozas") - (nil "Binjo") ("Björn Torkelsson" "Bjorn Torkelsson") ("Brian Fox" "Brian J. Fox") ("Brian P Templeton" "BT Templeton") ("Brian Sniffen" "Brian T. Sniffen") - (nil "Castor") - (nil "cg") ("David Abrahams" "Dave Abrahams") ("David J. Biesack" "David Biesack") ("David De La Harpe Golden" "David Golden") @@ -71,7 +67,6 @@ files.") ("David M. Koppelman" "David Koppelman") ("David M. Smith" "David Smith" "David M Smith") ("David O'Toole" "David T. O'Toole") - (nil "Deech") ("Deepak Goel" "D. Goel") ("Ed L. Cashin" "Ed L Cashin") ("Edward M. Reingold" "Ed\\(ward\\( M\\)?\\)? Reingold" "Reingold Edward M") @@ -79,8 +74,6 @@ files.") ("Eric M. Ludlam" "Eric Ludlam") ("Eric S. Raymond" "Eric Raymond") ("Fabián Ezequiel Gallina" "Fabian Ezequiel Gallina" "Fabi.n E\\. Gallina") - (nil "felix") - (nil "foudfou") ("Francis Litterio" "Fran Litterio") ("Francis J. Wright" "Dr Francis J. Wright" "Francis Wright") ("François Pinard" "Francois Pinard") @@ -91,7 +84,6 @@ files.") ("Hallvard B. Furuseth" "Hallvard B Furuseth" "Hallvard Furuseth") ("Hrvoje Nikšić" "Hrvoje Niksic") ;; lisp/org/ChangeLog.1 2010-11-11. - (nil "immerrr") (nil "aaa bbb") (nil "Code Extracted") ; lisp/newcomment.el's "Author:" header ("Jaeyoun Chung" "Jae-youn Chung" "Jae-you Chung" "Chung Jae-youn") @@ -121,8 +113,6 @@ files.") ("Kim F. Storm" "Kim Storm") ("Kyle Jones" "Kyle E. Jones") ("Lars Magne Ingebrigtsen" "Lars Ingebrigtsen") - (nil "LynX") - (nil "lu4nx") ("Marcus G. Daniels" "Marcus Daniels") ("Mark D. Baushke" "Mark D Baushke") ("Mark E. Shoulson" "Mark Shoulson") @@ -142,7 +132,6 @@ files.") ("Noorul Islam" "Noorul Islam K M") ;;; ("Tetsurou Okazaki" "OKAZAKI Tetsurou") ; FIXME? ("Óscar Fuentes" "Oscar Fuentes") - (nil "oblique") ("Paul Eggert" "Paul R\\. Eggert") ("Pavel Janík" "Pavel Janík Ml." "Pavel Janik Ml." "Pavel Janik") ("Pavel Kobiakov" "Pavel Kobyakov") @@ -154,10 +143,8 @@ files.") ("Philipp Stephani" "Philipp .*phst@google") ("Piotr Zieliński" "Piotr Zielinski") ("Przemysław Wojnowski" "Przemyslaw Wojnowski") - ("R. Bernstein" "rocky") ("Rainer Schöpf" "Rainer Schoepf") ("Raja R. Harinath" "Raja R Harinath") - ("Rasmus Pank Roulund" "Rasmus") ("Richard G. Bielawski" "Richard G Bielawski" "Richard Bielawski") ("Richard King" "Dick King") ("Richard M. Stallman" "Richard Stallman" "rms@gnu.org") @@ -168,14 +155,11 @@ files.") ("Ron Schnell" "Ronnie Schnell") ("Rui-Tao Dong" "Rui-Tao Dong ~{6-HpLN~}") ("Ryan Thompson" "Ryan .*rct@thompsonclan") - (nil "rzl24ozi") ("Sacha Chua" "Sandra Jean Chua") ("Sam Steingold" "Sam Shteingold") ("Satyaki Das" "Indexed search by Satyaki Das") ("Sébastien Vauban" "Sebastien Vauban") ("Sergey Litvinov" "Litvinov Sergey") - ("Simen Heggestøyl" "Simen") - (nil "sj") ("Shun-ichi Goto" "Shun-ichi GOTO") ;; There are other Stefans. ;;; ("Stefan Monnier" "Stefan") @@ -198,11 +182,9 @@ files.") ("Toru Tomabechi" "Toru TOMABECHI") ("Tsugutomo Enami" "enami tsugutomo") ("Ulrich Müller" "Ulrich Mueller") - (nil "vividsnow") ("Vincent Del Vecchio" "Vince Del Vecchio") ("William M. Perry" "Bill Perry") ("Wlodzimierz Bzyl" "W.*dek Bzyl") - (nil "xyblor") ("Yoni Rabkin" "Yoni Rabkin Katzenell") ("Yoshinori Koseki" "KOSEKI Yoshinori" "小関 吉則") ("Yutaka NIIBE" "NIIBE Yutaka") @@ -827,20 +809,7 @@ Changes to files in this list are not listed.") "obsolete/scribe.el" "cp51932.el" "eucjp-ms.el" - "lisp.mk" - "update-game-score.exe.manifest" - "lisp/obsolete/awk-mode.el" - "lisp/obsolete/iso-acc.el" - "lisp/obsolete/iso-insert.el" - "lisp/obsolete/resume.el" - "lisp/obsolete/scribe.el" - "lisp/obsolete/swedish.el" - "lisp/obsolete/spell.el" - "lisp/obsolete/swedish.el" - "lisp/obsolete/sym-comp.el" - "library-of-babel.org" - "flymake-elisp.el" - "flymake-ui.el") + "lisp.mk") "File names which are valid, but no longer exist (or cannot be found) in the repository.") @@ -925,7 +894,6 @@ in the repository.") ("progmodes/octave-inf.el" . "octave.el") ("progmodes/octave-mod.el" . "octave.el") ;; Obsolete. - ("lisp/gs.el" . "gs.el") ("emacs-lisp/assoc.el" . "assoc.el") ("emacs-lisp/cust-print.el" . "cust-print.el") ("emacs-lisp/gulp.el" . "gulp.el") diff --git a/admin/gitmerge.el b/admin/gitmerge.el index 1058088cce9..71b1761970c 100644 --- a/admin/gitmerge.el +++ b/admin/gitmerge.el @@ -50,11 +50,22 @@ (defvar gitmerge-skip-regexp ;; We used to include "sync" in there, but in my experience it only ;; caused false positives. --Stef - "back[- ]?port\\|cherry picked from commit\\|\\(do\\( no\\|n['’]\\)t\\|no need to\\) merge\\|\ -re-?generate\\|bump version\\|from trunk\\|Auto-commit" + (let ((skip "back[- ]?port\\|cherry picked from commit\\|\ +\\(do\\( no\\|n['’]\\)t\\|no need to\\) merge\\|\ +bump 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. + ;; These should be covered by "bump version" and "auto-commit". + ;; It doesn't do much harm if we merge one of those files by mistake. + ;; So it's better to err on the side of false negatives. + (concat skip "\\|re-?generate\\|from trunk"))) "Regexp matching logs of revisions that might be skipped. `gitmerge-missing' will ask you if it should skip any matches.") +(defvar gitmerge-minimum-missing 10 + "Minimum number of missing commits to consider merging in batch mode.") + (defvar gitmerge-status-file (expand-file-name "gitmerge-status" user-emacs-directory) "File where missing commits will be saved between sessions.") @@ -67,8 +78,9 @@ re-?generate\\|bump version\\|from trunk\\|Auto-commit" '((t (:strike-through t))) "Face for skipped commits.") -(defconst gitmerge-default-branch "origin/emacs-25" - "Default for branch that should be merged.") +(defvar gitmerge-default-branch nil + "Default for branch that should be merged. +If nil, the function `gitmerge-default-branch' guesses.") (defconst gitmerge-buffer "*gitmerge*" "Working buffer for gitmerge.") @@ -103,6 +115,21 @@ re-?generate\\|bump version\\|from trunk\\|Auto-commit" (defvar gitmerge--commits nil) (defvar gitmerge--from nil) +(defun gitmerge-emacs-version (&optional branch) + "Return the major version of Emacs, optionally in BRANCH." + (with-temp-buffer + (if (not branch) + (insert-file-contents "configure.ac") + (call-process "git" nil t nil "show" (format "%s:configure.ac" branch)) + (goto-char (point-min))) + (re-search-forward "^AC_INIT([^,]+, \\([0-9]+\\)\\.") + (string-to-number (match-string 1)))) + +(defun gitmerge-default-branch () + "Default for branch that should be merged; eg \"origin/emacs-26\"." + (or gitmerge-default-branch + (format "origin/emacs-%s" (1- (gitmerge-emacs-version))))) + (defun gitmerge-get-sha1 () "Get SHA1 from commit at point." (save-excursion @@ -182,11 +209,13 @@ Will detect a default set of skipped revision by looking at cherry mark and search for `gitmerge-skip-regexp'. The result is a list with entries of the form (SHA1 . SKIP), where SKIP denotes if and why this commit should be skipped." + (message "Finding missing commits...") (let (commits) ;; Go through the log and remember all commits that match ;; `gitmerge-skip-regexp' or are marked by --cherry-mark. (with-temp-buffer (call-process "git" nil t nil "log" "--cherry-mark" "--left-only" + "--no-decorate" (concat from "..." (car (vc-git-branches)))) (goto-char (point-max)) (while (re-search-backward "^commit \\(.+\\) \\([0-9a-f]+\\).*" nil t) @@ -203,6 +232,7 @@ if and why this commit should be skipped." (when (re-search-forward gitmerge-skip-regexp nil t) (setcdr (car commits) "R")))))) (delete-region (point) (point-max)))) + (message "Finding missing commits...done") (nreverse commits))) (defun gitmerge-setup-log-buffer (commits from) @@ -291,23 +321,47 @@ Returns non-nil if conflicts remain." ;; (pop-to-buffer (current-buffer)) (debug 'before-resolve) )) ;; Try to resolve the conflicts. - (cond - ((member file '("configure" "lisp/ldefs-boot.el" - "lisp/emacs-lisp/cl-loaddefs.el")) - ;; We are in the file's buffer, so names are relative. - (call-process "git" nil t nil "checkout" "--" - (file-name-nondirectory file)) - (revert-buffer nil 'noconfirm)) - (t - (goto-char (point-max)) - (while (re-search-backward smerge-begin-re nil t) - (save-excursion - (ignore-errors - (smerge-match-conflict) - (smerge-resolve)))) - ;; (when (derived-mode-p 'change-log-mode) - ;; (pop-to-buffer (current-buffer)) (debug 'after-resolve)) - (save-buffer))) + (let (temp) + (cond + ((and (equal file "etc/NEWS") + (ignore-errors + (setq temp + (format "NEWS.%s" + (gitmerge-emacs-version gitmerge--from)))) + (file-exists-p temp) + (or noninteractive + (y-or-n-p "Try to fix NEWS conflict? "))) + (let ((relfile (file-name-nondirectory file)) + (tempfile (make-temp-file "gitmerge"))) + (unwind-protect + (progn + (call-process "git" nil `(:file ,tempfile) nil "diff" + (format ":1:%s" file) + (format ":3:%s" file)) + (call-process "git" nil t nil "reset" "--" relfile) + (call-process "git" nil t nil "checkout" "--" relfile) + (revert-buffer nil 'noconfirm) + (call-process "patch" tempfile nil nil temp) + (call-process "git" nil t nil "add" "--" temp)) + (delete-file tempfile)))) + ;; Generated files. + ((member file '("lisp/ldefs-boot.el")) + ;; We are in the file's buffer, so names are relative. + (call-process "git" nil t nil "reset" "--" + (file-name-nondirectory file)) + (call-process "git" nil t nil "checkout" "--" + (file-name-nondirectory file)) + (revert-buffer nil 'noconfirm)) + (t + (goto-char (point-max)) + (while (re-search-backward smerge-begin-re nil t) + (save-excursion + (ignore-errors + (smerge-match-conflict) + (smerge-resolve)))) + ;; (when (derived-mode-p 'change-log-mode) + ;; (pop-to-buffer (current-buffer)) (debug 'after-resolve)) + (save-buffer)))) (goto-char (point-min)) (prog1 (re-search-forward smerge-begin-re nil t) (unless exists (kill-buffer)))))))) @@ -387,7 +441,9 @@ Throw an user-error if we cannot resolve automatically." (setq conflicted t) ;; Mark as resolved (call-process "git" nil t nil "add" file))) - (when conflicted + (if (not conflicted) + (and files (not (gitmerge-commit)) + (error "Error committing resolution - fix it manually")) (with-current-buffer (get-buffer-create gitmerge-warning-buffer) (erase-buffer) (insert "For the following files, conflicts could\n" @@ -413,6 +469,12 @@ Throw an user-error if we cannot resolve automatically." "diff" "--name-only") (zerop (buffer-size)))) +(defun gitmerge-commit () + "Commit, and return non-nil if it succeeds." + (with-current-buffer (get-buffer-create gitmerge-output-buffer) + (erase-buffer) + (eq 0 (call-process "git" nil t nil "commit" "--no-edit")))) + (defun gitmerge-maybe-resume () "Check if we have to resume a merge. If so, add no longer conflicted files and commit." @@ -425,7 +487,7 @@ If so, add no longer conflicted files and commit." (not (gitmerge-repo-clean))) (user-error "Repository is not clean")) (when statusexist - (if (not (y-or-n-p "Resume merge? ")) + (if (or noninteractive (not (y-or-n-p "Resume merge? "))) (progn (delete-file gitmerge-status-file) ;; No resume. @@ -434,11 +496,8 @@ If so, add no longer conflicted files and commit." (gitmerge-resolve-unmerged) ;; Commit the merge. (when mergehead - (with-current-buffer (get-buffer-create gitmerge-output-buffer) - (erase-buffer) - (unless (zerop (call-process "git" nil t nil - "commit" "--no-edit")) - (error "Git error during merge - fix it manually")))) + (or (gitmerge-commit) + (error "Git error during merge - fix it manually"))) ;; Successfully resumed. t)))) @@ -494,8 +553,12 @@ Branch FROM will be prepended to the list." (list (if (gitmerge-maybe-resume) 'resume - (completing-read "Merge branch: " (gitmerge-get-all-branches) - nil t gitmerge-default-branch)))))) + (if noninteractive + (or (pop command-line-args-left) + (gitmerge-default-branch)) + (completing-read "Merge branch: " + (gitmerge-get-all-branches) + nil t (gitmerge-default-branch)))))))) (let ((default-directory (vc-git-root default-directory))) (if (eq from 'resume) (progn @@ -507,6 +570,12 @@ Branch FROM will be prepended to the list." (setq gitmerge--from from) (when (null gitmerge--commits) (user-error "Nothing to merge")) + (and noninteractive + gitmerge-minimum-missing + (< (length gitmerge--commits) gitmerge-minimum-missing) + (user-error "Number of missing commits (%s) is less than %s" + (length gitmerge--commits) + gitmerge-minimum-missing)) (with-current-buffer (gitmerge-setup-log-buffer gitmerge--commits gitmerge--from) (goto-char (point-min)) @@ -517,7 +586,8 @@ Branch FROM will be prepended to the list." "(C) Detected backport (cherry-mark), (R) Log matches " "regexp, (M) Manually picked\n\n") (gitmerge-mode) - (pop-to-buffer (current-buffer)))))) + (pop-to-buffer (current-buffer)) + (if noninteractive (gitmerge-start-merge)))))) (defun gitmerge-start-merge () (interactive) diff --git a/admin/grammars/make.by b/admin/grammars/make.by index 3f550dfb201..da1320dbf0b 100644 --- a/admin/grammars/make.by +++ b/admin/grammars/make.by @@ -54,15 +54,20 @@ %% +;; Escape the ,@ below because the reader doesn't correctly detect +;; old-style backquotes for this case. The backslashes can be removed +;; once old-style backquotes are completely gone (probably in +;; Emacs 28). + Makefile : bol newline (nil) | bol variable - ( ,@$2 ) + ( \,@$2 ) | bol rule - ( ,@$2 ) + ( \,@$2 ) | bol conditional - ( ,@$2 ) + ( \,@$2 ) | bol include - ( ,@$2 ) + ( \,@$2 ) | whitespace ( nil ) | newline ( nil ) ; @@ -125,13 +130,13 @@ colons: COLON COLON () ; element-list: elements newline - ( ,@$1 ) + ( \,@$1 ) ; elements: element some-whitespace elements - ( ,@$1 ,@$3 ) + ( \,@$1 ,@$3 ) | element - ( ,@$1 ) + ( \,@$1 ) | ;;EMPTY ; diff --git a/admin/make-tarball.txt b/admin/make-tarball.txt index 6d6312c9b1b..ac6d15d6cee 100644 --- a/admin/make-tarball.txt +++ b/admin/make-tarball.txt @@ -5,7 +5,7 @@ Instructions to create pretest or release tarballs. -*- coding: utf-8 -*- Steps to take before starting on the first pretest in any release sequence: -0. The release branch (e.g. emacs-25) should already have been made +0. The release branch (e.g. emacs-26) should already have been made and you should use it for all that follows. Diffs from this branch should be going to the emacs-diffs mailing list. diff --git a/admin/merge-gnulib b/admin/merge-gnulib index 42edfbbd367..9fe0021a689 100755 --- a/admin/merge-gnulib +++ b/admin/merge-gnulib @@ -33,7 +33,7 @@ GNULIB_MODULES=' d-type diffseq dtoastr dtotimespec dup2 environ execinfo explicit_bzero faccessat fcntl fcntl-h fdatasync fdopendir - filemode filevercmp flexmember fstatat fsync + filemode filevercmp flexmember fstatat fsusage fsync getloadavg getopt-gnu gettime gettimeofday gitlog-to-changelog ignore-value intprops largefile lstat manywarnings memrchr minmax mkostemp mktime nstrftime diff --git a/admin/notes/git-workflow b/admin/notes/git-workflow index 83e81c68ef0..54657866ef5 100644 --- a/admin/notes/git-workflow +++ b/admin/notes/git-workflow @@ -19,15 +19,15 @@ Initial setup ============= Then we want to clone the repository. We normally want to have both -the current master and the emacs-25 branch. +the current master and the emacs-26 branch. mkdir ~/emacs cd ~/emacs git clone <membername>@git.sv.gnu.org:/srv/git/emacs.git master (cd master; git config push.default current) -./master/admin/git-new-workdir master emacs-25 -cd emacs-25 -git checkout emacs-25 +./master/admin/git-new-workdir master emacs-26 +cd emacs-26 +git checkout emacs-26 You now have both branches conveniently accessible, and you can do "git pull" in them once in a while to keep updated. @@ -57,11 +57,11 @@ you commit your change locally and then send a patch file as a bug report as described in ../../CONTRIBUTE. -Backporting to emacs-25 +Backporting to emacs-26 ======================= If you have applied a fix to the master, but then decide that it should -be applied to the emacs-25 branch, too, then +be applied to the emacs-26 branch, too, then cd ~/emacs/master git log @@ -71,7 +71,7 @@ which will look like commit 958b768a6534ae6e77a8547a56fc31b46b63710b -cd ~/emacs/emacs-25 +cd ~/emacs/emacs-26 git cherry-pick -xe 958b768a6534ae6e77a8547a56fc31b46b63710b and add "Backport:" to the commit string. Then @@ -79,17 +79,17 @@ and add "Backport:" to the commit string. Then git push -Merging emacs-25 to the master +Merging emacs-26 to the master ============================== It is recommended to use the file gitmerge.el in the admin directory -for merging 'emacs-25' into 'master'. It will take care of many +for merging 'emacs-26' 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-25' to +use the 'merge' command to transport commits from 'emacs-26' 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. @@ -102,11 +102,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-25', which you should accept. Merging a local tracking +'origin/emacs-26', 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-25' which are not yet +You will now see the list of commits from 'emacs-26' which 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/spelling b/admin/notes/spelling new file mode 100644 index 00000000000..a63d4bba849 --- /dev/null +++ b/admin/notes/spelling @@ -0,0 +1,11 @@ +Re "behavior" vs "behaviour", etc. + +- GNU Emacs originated in the US. + +- If there is a choice between US vs UK spelling for a word + for new text (code, docs), choose the US variant. + +- It's probably (IMHO --ttn, 2017-10-13) not a high priority to + change existing text; use your best judgement (ask if unsure). + +- http://lists.gnu.org/archive/html/emacs-devel/2005-06/msg00489.html diff --git a/admin/nt/dist-build/README-windows-binaries b/admin/nt/dist-build/README-windows-binaries index 27a5483c02b..39a5871b6a0 100644 --- a/admin/nt/dist-build/README-windows-binaries +++ b/admin/nt/dist-build/README-windows-binaries @@ -27,17 +27,17 @@ Contains a 32-bit build of Emacs without dependencies In addition, we provide the following files which will not be useful for most end-users. -emacs-26-x86_64-deps.zip +emacs-27-x86_64-deps.zip 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-26-i686-deps.zip +emacs-27-i686-deps.zip The 32-bit version of the dependencies. -emacs-26-deps-mingw-w64-src.zip +emacs-27-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 fe98ebdcc7c..493a128c099 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="26" +EMACS_MAJOR_VERSION="27" ## Options @@ -103,7 +103,8 @@ def gather_deps(deps, arch, directory): ## And package them up os.chdir(directory) print("Zipping: {}".format(arch)) - check_output_maybe("zip -9r ../../emacs-26-{}-deps.zip *".format(arch), + check_output_maybe("zip -9r ../../emacs-{}-{}{}-deps.zip *" + .format(EMACS_MAJOR_VERSION, DATE, arch), shell=True) os.chdir("../../") @@ -167,8 +168,8 @@ def gather_source(deps): p.map(download_source,to_download) print("Zipping") - check_output_maybe("zip -9 ../emacs-{}-deps-mingw-w64-src.zip *" - .format(EMACS_MAJOR_VERSION), + check_output_maybe("zip -9 ../emacs-{}-{}deps-mingw-w64-src.zip *" + .format(EMACS_MAJOR_VERSION,DATE), shell=True) os.chdir("..") @@ -188,13 +189,16 @@ if(os.environ["MSYSTEM"] != "MSYS"): parser = argparse.ArgumentParser() +parser.add_argument("-s", help="snapshot build", + action="store_true") + parser.add_argument("-t", help="32 bit deps only", action="store_true") parser.add_argument("-f", help="64 bit deps only", action="store_true") -parser.add_argument("-s", help="source code only", +parser.add_argument("-r", help="source code only", action="store_true") parser.add_argument("-c", help="clean only", @@ -204,19 +208,24 @@ parser.add_argument("-d", help="dry run", action="store_true") args = parser.parse_args() -do_all=not (args.c or args.s or args.f or args.t) +do_all=not (args.c or args.r or args.f or args.t) deps=extract_deps() DRY_RUN=args.d +if args.s: + DATE="{}-".format(check_output(["date", "+%Y-%m-%d"]).decode("utf-8").strip()) +else: + DATE="" + if( do_all or args.t ): gather_deps(deps,"i686","mingw32") if( do_all or args.f ): gather_deps(deps,"x86_64","mingw64") -if( do_all or args.s ): +if( do_all or args.r ): gather_source(deps) if( args.c ): diff --git a/admin/nt/dist-build/build-zips.sh b/admin/nt/dist-build/build-zips.sh index d008626bb3b..01c237152a9 100755 --- a/admin/nt/dist-build/build-zips.sh +++ b/admin/nt/dist-build/build-zips.sh @@ -19,14 +19,13 @@ function git_up { - echo Making git worktree for Emacs $VERSION + echo [build] Making git worktree for Emacs $VERSION cd $HOME/emacs-build/git/emacs-$MAJOR_VERSION git pull - git worktree add ../emacs-$BRANCH emacs-$BRANCH + git worktree add ../$BRANCH $BRANCH - cd ../emacs-$BRANCH + cd ../$BRANCH ./autogen.sh - } function build_zip { @@ -35,44 +34,80 @@ function build_zip { PKG=$2 HOST=$3 - echo Building Emacs-$VERSION for $ARCH + echo [build] Building Emacs-$VERSION for $ARCH if [ $ARCH == "i686" ] then PATH=/mingw32/bin:$PATH MSYSTEM=MINGW32 fi + ## Clean the install location because we use it twice + rm -rf $HOME/emacs-build/install/emacs-$VERSION/$ARCH mkdir --parents $HOME/emacs-build/build/emacs-$VERSION/$ARCH cd $HOME/emacs-build/build/emacs-$VERSION/$ARCH export PKG_CONFIG_PATH=$PKG - ../../../git/emacs-$BRANCH/configure \ - --without-dbus \ - --host=$HOST --without-compress-install \ - CFLAGS="-O2 -static -g3" - make -j 8 install \ + + ## Running configure forces a rebuild of the C core which takes + ## time that is not always needed + if (($CONFIG)) + then + echo [build] Configuring Emacs $ARCH + ../../../git/$BRANCH/configure \ + --without-dbus \ + --host=$HOST --without-compress-install \ + $CACHE \ + CFLAGS="-O2 -static -g3" + fi + + make -j 16 install \ prefix=$HOME/emacs-build/install/emacs-$VERSION/$ARCH cd $HOME/emacs-build/install/emacs-$VERSION/$ARCH cp $HOME/emacs-build/deps/libXpm/$ARCH/libXpm-noX4.dll bin - zip -r -9 emacs-$VERSION-$ARCH-no-deps.zip * - mv emacs-$VERSION-$ARCH-no-deps.zip $HOME/emacs-upload + zip -r -9 emacs-$OF_VERSION-$ARCH-no-deps.zip * + mv emacs-$OF_VERSION-$ARCH-no-deps.zip $HOME/emacs-upload rm bin/libXpm-noX4.dll - unzip $HOME/emacs-build/deps/emacs-26-$ARCH-deps.zip - zip -r -9 emacs-$VERSION-$ARCH.zip * - mv emacs-$VERSION-$ARCH.zip ~/emacs-upload + + if [ -z $SNAPSHOT ]; + then + DEPS_FILE=$HOME/emacs-build/deps/emacs-$MAJOR_VERSION-$ARCH-deps.zip + else + ## Pick the most recent snapshot whatever that is + DEPS_FILE=`ls $HOME/emacs-build/deps/emacs-$MAJOR_VERSION-*-$ARCH-deps.zip | tail -n 1` + fi + + echo [build] Using $DEPS_FILE + unzip $DEPS_FILE + + zip -r -9 emacs-$OF_VERSION-$ARCH.zip * + mv emacs-$OF_VERSION-$ARCH.zip ~/emacs-upload } +function build_installer { + ARCH=$1 + cd $HOME/emacs-build/install/emacs-$VERSION + echo [build] Calling makensis in `pwd` + cp ../../git/$BRANCH/admin/nt/dist-build/emacs.nsi . + + makensis -v4 \ + -DARCH=$ARCH -DEMACS_VERSION=$ACTUAL_VERSION \ + -DOUT_VERSION=$OF_VERSION emacs.nsi + rm emacs.nsi + mv emacs-$OF_VERSION-$ARCH-installer.exe ~/emacs-upload +} -##set -o xtrace set -o errexit SNAPSHOT= +CACHE= +BUILD=1 BUILD_32=1 BUILD_64=1 GIT_UP=0 +CONFIG=1 -while getopts "36ghsV:" opt; do +while getopts "36ghnsiV:" opt; do case $opt in 3) BUILD_32=1 @@ -90,6 +125,12 @@ while getopts "36ghsV:" opt; do BUILD_64=0 GIT_UP=1 ;; + n) + CONFIG=0 + ;; + i) + BUILD=0 + ;; V) VERSION=$OPTARG ;; @@ -101,6 +142,7 @@ while getopts "36ghsV:" opt; do echo " -3 32 bit build only" echo " -6 64 bit build only" echo " -g git update and worktree only" + echo " -i build installer only" exit 0 ;; \?) @@ -111,7 +153,6 @@ done if [ -z $VERSION ]; then - echo "doing version thing" VERSION=` sed -n 's/^AC_INIT(GNU Emacs,[ ]*\([^ ,)]*\).*/\1/p' < ../../../configure.ac ` @@ -119,14 +160,30 @@ fi if [ -z $VERSION ]; then - echo Cannot determine Emacs version + echo [build] Cannot determine Emacs version exit 1 fi MAJOR_VERSION="$(echo $VERSION | cut -d'.' -f1)" -BRANCH=$VERSION + +## ACTUAL VERSION is the version declared by emacs +ACTUAL_VERSION=$VERSION + +## VERSION includes the word snapshot if necessary VERSION=$VERSION$SNAPSHOT +## OF version includes the date if we have a snapshot +OF_VERSION=$VERSION + +if [ -z $SNAPSHOT ]; +then + BRANCH=emacs-$VERSION +else + BRANCH=master + CACHE=-C + OF_VERSION="$VERSION-`date +%Y-%m-%d`" +fi + if (($GIT_UP)) then git_up @@ -134,12 +191,20 @@ fi if (($BUILD_64)) then - build_zip x86_64 /mingw64/lib/pkgconfig x86_64-w64-mingw32 + if (($BUILD)) + then + build_zip x86_64 /mingw64/lib/pkgconfig x86_64-w64-mingw32 + fi + build_installer x86_64 fi ## Do the 64 bit build first, because we reset some environment ## variables during the 32 bit which will break the build. if (($BUILD_32)) then - build_zip i686 /mingw32/lib/pkgconfig i686-w64-mingw32 + if (($BUILD)) + then + build_zip i686 /mingw32/lib/pkgconfig i686-w64-mingw32 + fi + build_installer i686 fi diff --git a/admin/nt/dist-build/emacs.nsi b/admin/nt/dist-build/emacs.nsi new file mode 100644 index 00000000000..dce8f3db4a3 --- /dev/null +++ b/admin/nt/dist-build/emacs.nsi @@ -0,0 +1,88 @@ +!include MUI2.nsh +!include LogicLib.nsh +!include x64.nsh + +Outfile "emacs-${OUT_VERSION}-${ARCH}-installer.exe" + + +SetCompressor /solid lzma + +Var StartMenuFolder + + +!define MUI_WELCOMEPAGE_TITLE "Emacs" +!define MUI_WELCOMEPAGE_TITLE_3LINES +!define MUI_WELCOMEPAGE_TEXT "Welcome to Emacs -- the editor of a lifetime." + +!define MUI_WELCOMEFINISHPAGE_BITMAP "${ARCH}\share\emacs\${EMACS_VERSION}\etc\images\splash.bmp" +!define MUI_ICON "${ARCH}\share\emacs\${EMACS_VERSION}\etc\images\icons\hicolor\scalable\apps\emacs.ico" +!define MUI_UNICON "${ARCH}\share\emacs\${EMACS_VERSION}\etc\images\icons\hicolor\scalable\apps\emacs.ico" + +!insertmacro MUI_PAGE_WELCOME + + +!define MUI_LICENSEPAGE_TEXT_TOP "The GNU General Public License" +!insertmacro MUI_PAGE_LICENSE "${ARCH}\share\emacs\${EMACS_VERSION}\lisp\COPYING" + +!insertmacro MUI_PAGE_DIRECTORY +!insertmacro MUI_PAGE_INSTFILES + +!insertmacro MUI_PAGE_STARTMENU Application $StartMenuFolder + +!insertmacro MUI_UNPAGE_CONFIRM +!insertmacro MUI_UNPAGE_INSTFILES + +!insertmacro MUI_LANGUAGE "English" +Name Emacs-${EMACS_VERSION} + +function .onInit + ${If} ${RunningX64} + ${If} ${ARCH} == "x86_64" + StrCpy $INSTDIR "$PROGRAMFILES64\Emacs" + ${Else} + StrCpy $INSTDIR "$PROGRAMFILES32\Emacs" + ${Endif} + ${Else} + ${If} ${ARCH} == "x86_64" + Quit + ${Else} + StrCpy $INSTDIR "$PROGRAMFILES\Emacs" + ${Endif} + ${EndIf} +functionend + + +Section + + SetOutPath $INSTDIR + + File /r ${ARCH} + # define uninstaller name + WriteUninstaller $INSTDIR\Uninstall.exe + + !insertmacro MUI_STARTMENU_WRITE_BEGIN Application + ;Create shortcuts + CreateDirectory "$SMPROGRAMS\$StartMenuFolder" + CreateShortcut "$SMPROGRAMS\$StartMenuFolder\Uninstall.lnk" "$INSTDIR\Uninstall.exe" + + !insertmacro MUI_STARTMENU_WRITE_END + CreateShortCut "$SMPROGRAMS\$StartMenuFolder\Emacs.lnk" "$INSTDIR\${ARCH}\bin\runemacs.exe" +SectionEnd + + +# create a section to define what the uninstaller does. +# the section will always be named "Uninstall" +Section "Uninstall" + + # Always delete uninstaller first + Delete "$INSTDIR\Uninstall.exe" + + # now delete installed directory + RMDir /r "$INSTDIR\${ARCH}" + RMDir "$INSTDIR" + + !insertmacro MUI_STARTMENU_GETFOLDER Application $StartMenuFolder + + Delete "$SMPROGRAMS\$StartMenuFolder\Uninstall.lnk" + RMDir "$SMPROGRAMS\$StartMenuFolder" +SectionEnd diff --git a/build-aux/config.guess b/build-aux/config.guess index 6be308dd9c7..770cb5c7eb0 100755 --- a/build-aux/config.guess +++ b/build-aux/config.guess @@ -1,6 +1,6 @@ #! /bin/sh # Attempt to guess a canonical system name. -# Copyright 1992-2018 Free Software Foundation, Inc. +# Copyright 1992-2017 Free Software Foundation, Inc. timestamp='2017-12-17' diff --git a/build-aux/config.sub b/build-aux/config.sub index 9e84c010ecf..4fa505b51aa 100755 --- a/build-aux/config.sub +++ b/build-aux/config.sub @@ -1,6 +1,6 @@ #! /bin/sh # Configuration validation subroutine script. -# Copyright 1992-2018 Free Software Foundation, Inc. +# Copyright 1992-2017 Free Software Foundation, Inc. timestamp='2017-11-23' diff --git a/configure.ac b/configure.ac index 0fddfeab77c..c574d7dd0d1 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, 26.0.90, bug-gnu-emacs@gnu.org) +AC_INIT(GNU Emacs, 27.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. @@ -355,6 +355,7 @@ OPTION_DEFAULT_ON([libsystemd],[don't compile with libsystemd support]) OPTION_DEFAULT_OFF([cairo],[compile with Cairo drawing (experimental)]) OPTION_DEFAULT_ON([xml2],[don't compile with XML parsing support]) OPTION_DEFAULT_ON([imagemagick],[don't compile with ImageMagick image support]) +OPTION_DEFAULT_ON([json], [don't compile with native JSON support]) OPTION_DEFAULT_ON([xft],[don't use XFT for anti aliased fonts]) OPTION_DEFAULT_ON([libotf],[don't use libotf for OpenType font support]) @@ -899,10 +900,9 @@ AC_ARG_ENABLE([gcc-warnings], AC_ARG_ENABLE([check-lisp-object-type], [AS_HELP_STRING([--enable-check-lisp-object-type], - [Enable compile-time checks for the Lisp_Object data type, - which can catch some bugs during development. - The default is "no" if --enable-gcc-warnings is "no".])]) -if test "${enable_check_lisp_object_type-$gl_gcc_warnings}" != "no"; then + [Enable compile time checks for the Lisp_Object data type, + which can catch some bugs during development.])]) +if test "$enable_check_lisp_object_type" = yes; then AC_DEFINE([CHECK_LISP_OBJECT_TYPE], 1, [Define to enable compile-time checks for the Lisp_Object data type.]) fi @@ -1267,6 +1267,14 @@ esac AC_SUBST([PAXCTL_dumped]) AC_SUBST([PAXCTL_notdumped]) +# Makeinfo on macOS is ancient, check whether there is a more recent +# version installed by Homebrew. +AC_CHECK_PROG(HAVE_BREW, [brew], [yes]) +if test -n "$HAVE_BREW"; then + AC_PATH_PROG([MAKEINFO], [makeinfo], [], + [`brew --prefix texinfo 2>/dev/null`/bin$PATH_SEPARATOR$PATH]) +fi + ## Require makeinfo >= 4.13 (last of the 4.x series) to build the manuals. if test "${MAKEINFO:=makeinfo}" != "no"; then case `($MAKEINFO --version) 2>/dev/null` in @@ -2870,6 +2878,27 @@ fi AC_SUBST(LIBSYSTEMD_LIBS) AC_SUBST(LIBSYSTEMD_CFLAGS) +HAVE_JSON=no +JSON_OBJ= + +if test "${with_json}" = yes; then + EMACS_CHECK_MODULES([JSON], [jansson >= 2.7], + [HAVE_JSON=yes], [HAVE_JSON=no]) + if test "${HAVE_JSON}" = yes; then + AC_DEFINE(HAVE_JSON, 1, [Define if using Jansson.]) + JSON_OBJ=json.o + fi + + # Windows loads libjansson dynamically + if test "${opsys}" = "mingw32"; then + JSON_LIBS= + fi +fi + +AC_SUBST(JSON_LIBS) +AC_SUBST(JSON_CFLAGS) +AC_SUBST(JSON_OBJ) + NOTIFY_OBJ= NOTIFY_SUMMARY=no @@ -3424,7 +3453,9 @@ AC_SUBST(LIBXPM) ### Use -ljpeg if available, unless '--with-jpeg=no'. HAVE_JPEG=no LIBJPEG= -if test "${with_jpeg}" != "no"; then +if test "${NS_IMPL_COCOA}" = yes; then + : # Cocoa provides its own jpeg support, so do nothing. +elif test "${with_jpeg}" != "no"; then AC_CACHE_CHECK([for jpeglib 6b or later], [emacs_cv_jpeglib], [OLD_LIBS=$LIBS @@ -3559,7 +3590,7 @@ HAVE_PNG=no LIBPNG= PNG_CFLAGS= if test "${NS_IMPL_COCOA}" = yes; then - : # Nothing to do + : # Cocoa provides its own png support, so do nothing. elif test "${with_png}" != no; then # mingw32 loads the library dynamically. if test "$opsys" = mingw32; then @@ -3858,13 +3889,13 @@ if test "${with_xml2}" != "no"; then xcsdkdir="" ;; esac fi - CPPFLAGS="$CPPFLAGS -I$xcsdkdir/usr/include/libxml2" + CPPFLAGS="$CPPFLAGS -isystem${xcsdkdir}/usr/include/libxml2" AC_CHECK_HEADER(libxml/HTMLparser.h, [AC_CHECK_DECL(HTML_PARSE_RECOVER, HAVE_LIBXML2=yes, , [#include <libxml/HTMLparser.h>])]) CPPFLAGS="$SAVE_CPPFLAGS" if test "${HAVE_LIBXML2}" = "yes"; then - LIBXML2_CFLAGS="-I'$xcsdkdir/usr/include/libxml2'" + LIBXML2_CFLAGS="-isystem${xcsdkdir}/usr/include/libxml2" LIBXML2_LIBS="-lxml2" fi fi @@ -5364,7 +5395,7 @@ emacs_config_features= for opt in XAW3D XPM JPEG TIFF GIF PNG RSVG CAIRO IMAGEMAGICK SOUND GPM DBUS \ GCONF GSETTINGS NOTIFY ACL LIBSELINUX GNUTLS LIBXML2 FREETYPE M17N_FLT \ LIBOTF XFT ZLIB TOOLKIT_SCROLL_BARS X_TOOLKIT OLDXMENU X11 NS MODULES \ - XWIDGETS LIBSYSTEMD CANNOT_DUMP LCMS2; do + XWIDGETS LIBSYSTEMD JSON CANNOT_DUMP LCMS2; do case $opt in CANNOT_DUMP) eval val=\${$opt} ;; @@ -5414,6 +5445,7 @@ AS_ECHO([" Does Emacs use -lXaw3d? ${HAVE_XAW3D Does Emacs use -lotf? ${HAVE_LIBOTF} Does Emacs use -lxft? ${HAVE_XFT} Does Emacs use -lsystemd? ${HAVE_LIBSYSTEMD} + Does Emacs use -ljansson? ${HAVE_JSON} 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} diff --git a/doc/emacs/dired.texi b/doc/emacs/dired.texi index b8450ce9982..ff0b2ae3a77 100644 --- a/doc/emacs/dired.texi +++ b/doc/emacs/dired.texi @@ -648,6 +648,14 @@ Copy the specified files (@code{dired-do-copy}). The argument @var{new} is the directory to copy into, or (if copying a single file) the new name. This is like the shell command @code{cp}. +@vindex dired-create-destination-dirs +The option @code{dired-create-destination-dirs} controls whether Dired +should create non-existent directories in the destination while +copying/renaming files. The default value @code{nil} means Dired +never creates such missing directories; the value @code{always}, +means Dired automatically creates them; the value @code{ask} +means Dired asks you for confirmation before creating them. + @vindex dired-copy-preserve-time If @code{dired-copy-preserve-time} is non-@code{nil}, then copying with this command preserves the modification time of the old file in @@ -679,6 +687,9 @@ single file, the argument @var{new} is the new name of the file. If you rename several files, the argument @var{new} is the directory into which to move the files (this is like the shell command @command{mv}). +The option @code{dired-create-destination-dirs} controls whether Dired +should create non-existent directories in @var{new}. + Dired automatically changes the visited file name of buffers associated with renamed files so that they refer to the new names. diff --git a/doc/emacs/files.texi b/doc/emacs/files.texi index 586086dda28..881210aab9a 100644 --- a/doc/emacs/files.texi +++ b/doc/emacs/files.texi @@ -1280,13 +1280,8 @@ default), and @code{list-directory-verbose-switches} is a string giving the switches to use in a verbose listing (@code{"-l"} by default). -@vindex directory-free-space-program -@vindex directory-free-space-args In verbose directory listings, Emacs adds information about the -amount of free space on the disk that contains the directory. To do -this, it runs the program specified by -@code{directory-free-space-program} with arguments -@code{directory-free-space-args}. +amount of free space on the disk that contains the directory. The command @kbd{M-x delete-directory} prompts for a directory's name using the minibuffer, and deletes the directory if it is empty. If diff --git a/doc/emacs/text.texi b/doc/emacs/text.texi index bb837f94d3b..846d9fe8c62 100644 --- a/doc/emacs/text.texi +++ b/doc/emacs/text.texi @@ -457,6 +457,13 @@ non-@code{nil}, and in programming-language strings if @code{nil} for @code{electric-quote-string} and @code{t} for the other variables. +@vindex electric-quote-replace-double + You can also set the option @code{electric-quote-replace-double} to +a non-@code{nil} value. Then, typing @t{"} insert an appropriate +curved double quote depending on context: @t{“} at the beginning of +the buffer or after a line break, whitespace, opening parenthesis, or +quote character, and @t{”} otherwise. + Electric Quote mode is disabled by default. To toggle it in a single buffer, use @kbd{M-x electric-quote-local-mode}. To toggle it globally, type diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi index 1b0d314ee71..1a883e0f142 100644 --- a/doc/lispref/edebug.texi +++ b/doc/lispref/edebug.texi @@ -1702,3 +1702,33 @@ Whether or not to pause for @code{edebug-sit-for-seconds} on reaching a breakpoint. Set to @code{nil} to prevent the pause, non-@code{nil} to allow it. @end defopt + +@defopt edebug-behavior-alist +By default, this alist contains one entry with the key @code{edebug} +and a list of three functions, which are the default implementations +of the functions inserted in instrumented code: @code{edebug-enter}, +@code{edebug-before} and @code{edebug-after}. To change Edebug's +behavior globally, modify the default entry. + +Edebug's behavior may also be changed on a per-definition basis by +adding an entry to this alist, with a key of your choice and three +functions. Then set the @code{edebug-behavior} symbol property of an +instrumented definition to the key of the new entry, and Edebug will +call the new functions in place of its own for that definition. +@end defopt + +@defopt edebug-new-definition-function +A function run by Edebug after it wraps the body of a definition +or closure. After Edebug has initialized its own data, this function +is called with one argument, the symbol associated with the +definition, which may be the actual symbol defined or one generated by +Edebug. This function may be used to set the @code{edebug-behavior} +symbol property of each definition instrumented by Edebug. +@end defopt + +@defopt edebug-after-instrumentation-function +To inspect or modify Edebug's instrumentation before it is used, set +this variable to a function which takes one argument, an instrumented +top-level form, and returns either the same or a replacement form, +which Edebug will then use as the final result of instrumentation. +@end defopt diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index 6b59e319172..9389aa1ba19 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -455,6 +455,7 @@ Evaluation the program). * Backquote:: Easier construction of list structure. * Eval:: How to invoke the Lisp interpreter explicitly. +* Deferred Eval:: Deferred and lazy evaluation of forms. Kinds of Forms diff --git a/doc/lispref/eval.texi b/doc/lispref/eval.texi index 2590de30c79..b5d19f20c2d 100644 --- a/doc/lispref/eval.texi +++ b/doc/lispref/eval.texi @@ -20,11 +20,12 @@ function @code{eval}. @ifnottex @menu -* Intro Eval:: Evaluation in the scheme of things. -* Forms:: How various sorts of objects are evaluated. -* Quoting:: Avoiding evaluation (to put constants in the program). -* Backquote:: Easier construction of list structure. -* Eval:: How to invoke the Lisp interpreter explicitly. +* Intro Eval:: Evaluation in the scheme of things. +* Forms:: How various sorts of objects are evaluated. +* Quoting:: Avoiding evaluation (to put constants in the program). +* Backquote:: Easier construction of list structure. +* Eval:: How to invoke the Lisp interpreter explicitly. +* Deferred Eval:: Deferred and lazy evaluation of forms. @end menu @node Intro Eval @@ -877,3 +878,115 @@ particular elements, like this: @end group @end example @end defvar + +@node Deferred Eval +@section Deferred and Lazy Evaluation + +@cindex deferred evaluation +@cindex lazy evaluation + + + Sometimes it is useful to delay the evaluation of an expression, for +example if you want to avoid performing a time-consuming calculation +if it turns out that the result is not needed in the future of the +program. The @file{thunk} library provides the following functions +and macros to support such @dfn{deferred evaluation}: + +@cindex thunk +@defmac thunk-delay forms@dots{} +Return a @dfn{thunk} for evaluating the @var{forms}. A thunk is a +closure (@pxref{Closures}) that inherits the lexical environment of the +@code{thunk-delay} call. Using this macro requires +@code{lexical-binding}. +@end defmac + +@defun thunk-force thunk +Force @var{thunk} to perform the evaluation of the forms specified in +the @code{thunk-delay} that created the thunk. The result of the +evaluation of the last form is returned. The @var{thunk} also +``remembers'' that it has been forced: Any further calls of +@code{thunk-force} with the same @var{thunk} will just return the same +result without evaluating the forms again. +@end defun + +@defmac thunk-let (bindings@dots{}) forms@dots{} +This macro is analogous to @code{let} but creates ``lazy'' variable +bindings. Any binding has the form @w{@code{(@var{symbol} +@var{value-form})}}. Unlike @code{let}, the evaluation of any +@var{value-form} is deferred until the binding of the according +@var{symbol} is used for the first time when evaluating the +@var{forms}. Any @var{value-form} is evaluated at most once. Using +this macro requires @code{lexical-binding}. +@end defmac + +Example: + +@example +@group +(defun f (number) + (thunk-let ((derived-number + (progn (message "Calculating 1 plus 2 times %d" number) + (1+ (* 2 number))))) + (if (> number 10) + derived-number + number))) +@end group + +@group +(f 5) +@result{} 5 +@end group + +@group +(f 12) +@print{} Calculating 1 plus 2 times 12 +@result{} 25 +@end group + +@end example + +Because of the special nature of lazily bound variables, it is an error +to set them (e.g.@: with @code{setq}). + + +@defmac thunk-let* (bindings@dots{}) forms@dots{} +This is like @code{thunk-let} but any expression in @var{bindings} is allowed +to refer to preceding bindings in this @code{thunk-let*} form. Using +this macro requires @code{lexical-binding}. +@end defmac + +@example +@group +(thunk-let* ((x (prog2 (message "Calculating x...") + (+ 1 1) + (message "Finished calculating x"))) + (y (prog2 (message "Calculating y...") + (+ x 1) + (message "Finished calculating y"))) + (z (prog2 (message "Calculating z...") + (+ y 1) + (message "Finished calculating z"))) + (a (prog2 (message "Calculating a...") + (+ z 1) + (message "Finished calculating a")))) + (* z x)) + +@print{} Calculating z... +@print{} Calculating y... +@print{} Calculating x... +@print{} Finished calculating x +@print{} Finished calculating y +@print{} Finished calculating z +@result{} 8 + +@end group +@end example + +@code{thunk-let} and @code{thunk-let*} use thunks implicitly: their +expansion creates helper symbols and binds them to thunks wrapping the +binding expressions. All references to the original variables in the +body @var{forms} are then replaced by an expression that calls +@code{thunk-force} with the according helper variable as the argument. +So, any code using @code{thunk-let} or @code{thunk-let*} could be +rewritten to use thunks, but in many cases using these macros results +in nicer code than using thunks explicitly. diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi index 162fc1eb1ef..021a62a56ab 100644 --- a/doc/lispref/files.texi +++ b/doc/lispref/files.texi @@ -2110,7 +2110,7 @@ Note that the @samp{.~3~} in the two last examples is the backup part, not an extension. @end defun -@defun file-name-base &optional filename +@defun file-name-base filename This function is the composition of @code{file-name-sans-extension} and @code{file-name-nondirectory}. For example, @@ -2118,8 +2118,6 @@ and @code{file-name-nondirectory}. For example, (file-name-base "/my/home/foo.c") @result{} "foo" @end example - -The @var{filename} argument defaults to @code{buffer-file-name}. @end defun @node Relative File Names @@ -3140,7 +3138,8 @@ first, before handlers for jobs such as remote file access. @code{file-ownership-preserved-p}, @code{file-readable-p}, @code{file-regular-p}, @code{file-remote-p}, @code{file-selinux-context}, -@code{file-symlink-p}, @code{file-truename}, @code{file-writable-p}, +@code{file-symlink-p}, @code{file-system-info}, +@code{file-truename}, @code{file-writable-p}, @code{find-backup-file-name},@* @code{get-file-buffer}, @code{insert-directory}, @@ -3196,7 +3195,8 @@ first, before handlers for jobs such as remote file access. @code{file-ownership-pre@discretionary{}{}{}served-p}, @code{file-readable-p}, @code{file-regular-p}, @code{file-remote-p}, @code{file-selinux-context}, -@code{file-symlink-p}, @code{file-truename}, @code{file-writable-p}, +@code{file-symlink-p}, @code{file-system-info}, +@code{file-truename}, @code{file-writable-p}, @code{find-backup-file-name}, @code{get-file-buffer}, @code{insert-directory}, diff --git a/doc/lispref/functions.texi b/doc/lispref/functions.texi index c6188ce466d..c3e5dc0eb5b 100644 --- a/doc/lispref/functions.texi +++ b/doc/lispref/functions.texi @@ -1225,7 +1225,7 @@ This form defines a method like @code{cl-defmethod} does. @end table @end defmac -@defmac cl-defmethod name [qualifier] arguments &rest [docstring] body +@defmac cl-defmethod name [qualifier] arguments [&context (expr spec)@dots{}] &rest [docstring] body This macro defines a particular implementation for the generic function called @var{name}. The implementation code is given by @var{body}. If present, @var{docstring} is the documentation string @@ -1246,21 +1246,26 @@ This specializer requires the argument be @code{eql} to the given @item (head @var{object}) The argument must be a cons cell whose @code{car} is @code{eql} to @var{object}. -@item @var{struct-tag} -The argument must be an instance of a class named @var{struct-tag} +@item @var{struct-type} +The argument must be an instance of a class named @var{struct-type} defined with @code{cl-defstruct} (@pxref{Structures,,, cl, Common Lisp -Extensions for GNU Emacs Lisp}), or of one of its parent classes. +Extensions for GNU Emacs Lisp}), or of one of its child classes. @end table -Alternatively, the argument specializer can be of the form -@code{&context (@var{expr} @var{spec})}, in which case the value of -@var{expr} must be compatible with the specializer provided by -@var{spec}; @var{spec} can be any of the forms described above. In -other words, this form of specializer uses the value of @var{expr} -instead of arguments for the decision whether the method is -applicable. For example, @code{&context (overwrite-mode (eql t))} -will make the method compatible only when @code{overwrite-mode} is -turned on. +Method definitions can make use of a new argument-list keyword, +@code{&context}, which introduces extra specializers that test the +environment at the time the method is run. This keyword should appear +after the list of required arguments, but before any @code{&rest} or +@code{&optional} keywords. The @code{&context} specializers look much +like regular argument specializers---(@var{expr} @var{spec})---except +that @var{expr} is an expression to be evaluated in the current +context, and the @var{spec} is a value to compare against. For +example, @code{&context (overwrite-mode (eql t))} will make the method +applicable only when @code{overwrite-mode} is turned on. The +@code{&context} keyword can be followed by any number of context +specializers. Because the context specializers are not part of the +generic function's argument signature, they may be omitted in methods +that don't require them. The type specializer, @code{(@var{arg} @var{type})}, can specify one of the @dfn{system types} in the following list. When a parent type diff --git a/doc/lispref/numbers.texi b/doc/lispref/numbers.texi index c12ffe2cde7..e692ee1cc2f 100644 --- a/doc/lispref/numbers.texi +++ b/doc/lispref/numbers.texi @@ -1107,6 +1107,24 @@ bit is one in the result if, and only if, the @var{n}th bit is zero in @end example @end defun +@cindex popcount +@cindex Hamming weight +@cindex counting set bits +@defun logcount integer +This function returns the @dfn{Hamming weight} of @var{integer}: the +number of ones in the binary representation of @var{integer}. +If @var{integer} is negative, it returns the number of zero bits in +its two's complement binary representation. The result is always +nonnegative. + +@example +(logcount 43) ; 43 = #b101011 + @result{} 4 +(logcount -43) ; -43 = #b111...1010101 + @result{} 3 +@end example +@end defun + @node Math Functions @section Standard Mathematical Functions @cindex transcendental functions diff --git a/doc/lispref/strings.texi b/doc/lispref/strings.texi index 756e7efb957..c8261e316f2 100644 --- a/doc/lispref/strings.texi +++ b/doc/lispref/strings.texi @@ -121,7 +121,7 @@ character (i.e., an integer), @code{nil} otherwise. The following functions create strings, either from scratch, or by putting strings together, or by taking them apart. -@defun make-string count character +@defun make-string count character &optional multibyte This function returns a string made up of @var{count} repetitions of @var{character}. If @var{count} is negative, an error is signaled. @@ -132,6 +132,13 @@ This function returns a string made up of @var{count} repetitions of @result{} "" @end example + Normally, if @var{character} is an @acronym{ASCII} character, the +result is a unibyte string. But if the optional argument +@var{multibyte} is non-@code{nil}, the function will produce a +multibyte string instead. This is useful when you later need to +concatenate the result with non-@acronym{ASCII} strings or replace +some of its characters with non-@acronym{ASCII} characters. + Other functions to compare with this one include @code{make-vector} (@pxref{Vectors}) and @code{make-list} (@pxref{Building Lists}). @end defun diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index f590a20896f..c62862f2100 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -61,6 +61,7 @@ the character after point. * Checksum/Hash:: Computing cryptographic hashes. * GnuTLS Cryptography:: Cryptographic algorithms imported from GnuTLS. * Parsing HTML/XML:: Parsing HTML and XML. +* Parsing JSON:: Parsing and generating JSON values. * Atomic Changes:: Installing several buffer changes atomically. * Change Hooks:: Supplying functions to be run when text is changed. @end menu @@ -4516,9 +4517,9 @@ It should be somewhat more efficient on larger buffers than @cindex symmetric cipher @cindex cipher, symmetric -If compiled with GnuTLS, Emacs offers built-in cryptographic support. -Following the GnuTLS API terminology, the available tools are digests, -MACs, symmetric ciphers, and AEAD ciphers. + If compiled with GnuTLS, Emacs offers built-in cryptographic +support. Following the GnuTLS API terminology, the available tools +are digests, MACs, symmetric ciphers, and AEAD ciphers. The terms used herein, such as IV (Initialization Vector), require some familiarity with cryptography and will not be defined in detail. @@ -4536,7 +4537,7 @@ structure of the GnuTLS library. @cindex format of gnutls cryptography inputs @cindex gnutls cryptography inputs format -The inputs to GnuTLS cryptographic functions can be specified in + The inputs to GnuTLS cryptographic functions can be specified in several ways, both as primitive Emacs Lisp types or as lists. The list form is currently similar to how @code{md5} and @@ -4703,8 +4704,15 @@ IV used. @section Parsing HTML and XML @cindex parsing html -When Emacs is compiled with libxml2 support, the following functions -are available to parse HTML or XML text into Lisp object trees. + Emacs can be compiled with built-in libxml2 support. + +@defun libxml-available-p +This function returns non-@code{nil} if built-in libxml2 support is +available in this Emacs session. +@end defun + +When libxml2 support is available, the following functions can be used +to parse HTML or XML text into Lisp object trees. @defun libxml-parse-html-region start end &optional base-url discard-comments This function parses the text between @var{start} and @var{end} as @@ -4771,9 +4779,9 @@ about syntax). @cindex DOM @cindex Document Object Model -The @acronym{DOM} returned by @code{libxml-parse-html-region} (and the -other @acronym{XML} parsing functions) is a tree structure where each -node has a node name (called a @dfn{tag}), and optional key/value + The @acronym{DOM} returned by @code{libxml-parse-html-region} (and +the other @acronym{XML} parsing functions) is a tree structure where +each node has a node name (called a @dfn{tag}), and optional key/value @dfn{attribute} list, and then a list of @dfn{child nodes}. The child nodes are either strings or @acronym{DOM} objects. @@ -4891,6 +4899,98 @@ textual nodes that just contain white-space. @end table +@node Parsing JSON +@section Parsing and generating JSON values +@cindex JSON + + When Emacs is compiled with JSON support, it provides a couple of +functions to convert between Lisp objects and JSON values. Any JSON +value can be converted to a Lisp object, but not vice versa. +Specifically: + +@itemize + +@item +JSON has a couple of keywords: @code{null}, @code{false}, and +@code{true}. These are represented in Lisp using the keywords +@code{:null}, @code{:false}, and @code{t}, respectively. + +@item +JSON only has floating-point numbers. They can represent both Lisp +integers and Lisp floating-point numbers. + +@item +JSON strings are always Unicode strings. Lisp strings can contain +non-Unicode characters. + +@item +JSON has only one sequence type, the array. JSON arrays are +represented using Lisp vectors. + +@item +JSON has only one map type, the object. JSON objects are represented +using Lisp hashtables or alists. When an alist contains several +elements with the same key, Emacs uses only the first element for +serialization, in accordance with the behavior of @code{assq}. + +@end itemize + +@noindent +Note that @code{nil} is a valid alist and represents the empty JSON +object, @code{@{@}}, not @code{null}, @code{false}, or an empty array, +all of which are different JSON values. + + If some Lisp object can't be represented in JSON, the serialization +functions will signal an error of type @code{wrong-type-argument}. +The parsing functions will signal the following errors: + +@table @code + +@item json-end-of-file + Signaled when encountering a premature end of the input text. + +@item json-trailing-content + Signaled when encountering unexpected input after the first JSON + object parsed. + +@item json-parse-error + Signaled when encountering invalid JSON syntax. + +@end table + + Only top-level values (arrays and objects) can be serialized to +JSON. The subobjects within these top-level values can be of any +type. Likewise, the parsing functions will only return vectors, +hashtables, and alists. + + The parsing functions accept keyword arguments. Currently only one +keyword argument, @code{:object-type}, is recognized; its value can be +either @code{hash-table} to parse JSON objects as hashtables with +string keys (the default) or @code{alist} to parse them as alists. + +@defun json-serialize object +This function returns a new Lisp string which contains the JSON +representation of @var{object}. +@end defun + +@defun json-insert object +This function inserts the JSON representation of @var{object} into the +current buffer before point. +@end defun + +@defun json-parse-string string &key (object-type @code{hash-table}) +This function parses the JSON value in @var{string}, which must be a +Lisp string. +@end defun + +@defun json-parse-buffer &key (object-type @code{hash-table}) +This function reads the next JSON value from the current buffer, +starting at point. It moves point to the position immediately after +the value if a value could be read and converted to Lisp; otherwise it +doesn't move point. +@end defun + + @node Atomic Changes @section Atomic Change Groups @cindex atomic changes diff --git a/doc/misc/auth.texi b/doc/misc/auth.texi index f1667c49f1a..9cf16d8ed4f 100644 --- a/doc/misc/auth.texi +++ b/doc/misc/auth.texi @@ -86,7 +86,7 @@ password (known as the secret). Similarly, the auth-source library supports multiple storage backend, currently either the classic ``netrc'' backend, examples of which you -can see later in this document, the Secret Service API, and pass, the +can see later in this document, JSON files, the Secret Service API, and pass, the standard unix password manager. This is done with EIEIO-based backends and you can write your own if you want. @@ -169,6 +169,9 @@ get fancy, the default and simplest configuration is: ;;; use pass (@file{~/.password-store}) ;;; (@pxref{The Unix password store}) (setq auth-sources '(password-store)) +;;; JSON data in format [@{ "machine": "SERVER", +;;; "login": "USER", "password": "PASSWORD" @}...] +(setq auth-sources '("~/.authinfo.json.gpg")) @end lisp By adding multiple entries to @code{auth-sources} with a particular @@ -235,6 +238,16 @@ don't use a port entry, you match any Tramp method, as explained earlier. Since Tramp has about 88 connection methods, this may be necessary if you have an unusual (see earlier comment on those) setup. +The netrc format is directly translated into JSON, if you are into +that sort of thing. Just point to a JSON file with entries like this: + +@example +[ + @{ "machine": "yourmachine.com", "port": "http", + "login": "testuser", "password": "testpass" @} +] +@end example + @node Multiple GMail accounts with Gnus @chapter Multiple GMail accounts with Gnus diff --git a/doc/misc/ert.texi b/doc/misc/ert.texi index 9efca79e95a..3553560f497 100644 --- a/doc/misc/ert.texi +++ b/doc/misc/ert.texi @@ -321,6 +321,20 @@ summary as shown below: emacs -batch -l ert -f ert-summarize-tests-batch-and-exit output.log @end example +@vindex ert-quiet +By default, ERT in batch mode is quite verbose, printing a line with +result after each test. This gives you progress information: how many +tests have been executed and how many there are. However, in some +cases this much output may be undesirable. In this case, set +@code{ert-quiet} variable to a non-nil value: + +@example +emacs -batch -l ert -l my-tests.el \ + --eval "(let ((ert-quiet t)) (ert-run-tests-batch-and-exit))" +@end example + +In quiet mode ERT prints only unexpected results and summary. + If ERT is not part of your Emacs distribution, you may need to use @code{-L /path/to/ert/} so that Emacs can find it. You may need additional @code{-L} flags to ensure that @code{my-tests.el} and all the diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index 1b941bca2ab..8c2fc56dd6e 100644 --- a/doc/misc/gnus.texi +++ b/doc/misc/gnus.texi @@ -13216,6 +13216,11 @@ Also @pxref{Formatting Variables}. @subsection Server Commands @cindex server commands +The following keybinding are available in the server buffer. Be aware +that some of the commands will only work on servers that you've added +through this interface (with @kbd{a}), not with servers you've defined +in your init files. + @table @kbd @item v @@ -18487,7 +18492,7 @@ something along the lines of the following: (defun my-article-old-p () "Say whether an article is old." (< (time-to-days (date-to-time (mail-header-date gnus-headers))) - (- (time-to-days (current-time)) gnus-agent-expire-days))) + (- (time-to-days nil) gnus-agent-expire-days))) @end lisp with the predicate then defined as: diff --git a/doc/misc/texinfo.tex b/doc/misc/texinfo.tex index b0179d6b007..1987c50ba26 100644 --- a/doc/misc/texinfo.tex +++ b/doc/misc/texinfo.tex @@ -5,7 +5,10 @@ % \def\texinfoversion{2017-12-26.21} % -% Copyright 1985-1986, 1988, 1990-2018 Free Software Foundation, Inc. +% Copyright 1985, 1986, 1988, 1990, 1991, 1992, 1993, 1994, 1995, +% 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, +% 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 +% 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 diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index c1f941a640f..deaafb3d257 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -164,6 +164,7 @@ Using @value{tramp} * Ad-hoc multi-hops:: Declaring multiple hops in the file name. * Remote processes:: Integration with other Emacs packages. * Cleanup remote connections:: Cleanup remote connections. +* Archive file names:: Access to files in file archives. How file names, directories and localnames are mangled and managed @@ -407,7 +408,8 @@ since April 2007 (and removed in December 2016). GVFS integration started in February 2009. Remote commands on MS Windows hosts since September 2011. Ad-hoc multi-hop methods (with a changed syntax) re-enabled in November 2011. In November 2012, added Juergen -Hoetzel's @file{tramp-adb.el}. +Hoetzel's @file{tramp-adb.el}. Archive file names are supported since +December 2017. XEmacs support was stopped in January 2016. Since March 2017, @value{tramp} syntax mandates a method. @@ -529,24 +531,33 @@ of the local file name is the share exported by the remote host, @cindex dav method @cindex davs method -On systems, which have installed the virtual file system for the Gnome -Desktop (GVFS), its offered methods could be used by @value{tramp}. -Examples are @file{@trampfn{sftp,user@@host,/path/to/file}}, +On systems, which have installed the virtual file system for the +@acronym{GNOME} Desktop (GVFS), 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). -@anchor{Quick Start Guide: Google Drive} -@section Using Google Drive +@anchor{Quick Start Guide: GNOME Online Accounts based methods} +@section Using @acronym{GNOME} Online Accounts based methods +@cindex @acronym{GNOME} Online Accounts @cindex method gdrive @cindex gdrive method @cindex google drive +@cindex method owncloud +@cindex owncloud method +@cindex nextcloud -Another GVFS-based method allows to access a Google Drive file system. -The file name syntax is here always -@file{@trampfn{gdrive,john.doe@@gmail.com,/path/to/file}}. -@samp{john.doe@@gmail.com} stands here for your Google Drive account. +GVFS-based methods include also @acronym{GNOME} Online Accounts, which +support the @option{Files} service. These are the Google Drive file +system, and the OwnCloud/NextCloud file system. The file name syntax +is here always +@file{@trampfn{gdrive,john.doe@@gmail.com,/path/to/file}} +(@samp{john.doe@@gmail.com} stands here for your Google Drive +account), or @file{@trampfn{owncloud,user@@host#8081,/path/to/file}} +(@samp{8081} stands for the port number) for OwnCloud/NextCloud files. @anchor{Quick Start Guide: Android} @@ -1059,7 +1070,7 @@ numbers are not applicable to Android devices connected through USB@. @cindex gvfs based methods @cindex dbus -GVFS is the virtual file system for the Gnome Desktop, +GVFS is the virtual file system for the @acronym{GNOME} Desktop, @uref{https://en.wikipedia.org/wiki/GVFS}. Remote files on GVFS are mounted locally through FUSE and @value{tramp} uses this locally mounted directory internally. @@ -1112,6 +1123,18 @@ directory have the same @code{display-name}, such a situation must be avoided. OBEX is an FTP-like access protocol for cell phones and similar simple devices. @value{tramp} supports OBEX over Bluetooth. +@item @option{owncloud} +@cindex @acronym{GNOME} Online Accounts +@cindex method owncloud +@cindex owncloud method +@cindex nextcloud + +As the name indicates, the method @option{owncloud} allows you to +access OwnCloud or NextCloud hosted files and directories. Like the +@option{gdrive} method, your credentials must be populated in your +@command{Online Accounts} application outside Emacs. The method +supports port numbers. + @item @option{sftp} @cindex method sftp @cindex sftp method @@ -1133,8 +1156,11 @@ requires the SYNCE-GVFS plugin. @defopt tramp-gvfs-methods This user option is a list of external methods for GVFS@. By default, this list includes @option{afp}, @option{dav}, @option{davs}, -@option{gdrive}, @option{obex}, @option{sftp} and @option{synce}. -Other methods to include are: @option{ftp} and @option{smb}. +@option{gdrive}, @option{obex}, @option{owncloud}, @option{sftp} and +@option{synce}. Other methods to include are @option{ftp}, +@option{http}, @option{https} and @option{smb}. These methods are not +intended to be used directly as GVFS based method. Instead, they are +added here for the benefit of @ref{Archive file names}. @end defopt @@ -2284,6 +2310,7 @@ is a feature of Emacs that may cause missed prompts when using * Ad-hoc multi-hops:: Declaring multiple hops in the file name. * Remote processes:: Integration with other Emacs packages. * Cleanup remote connections:: Cleanup remote connections. +* Archive file names:: Access to files in file archives. @end menu @@ -2913,6 +2940,213 @@ that remote connection. @end deffn +@node Archive file names +@section Archive file names +@cindex file archives +@cindex archive file names +@cindex method archive +@cindex archive method + +@value{tramp} offers also transparent access to files inside file +archives. This is possible only on machines which have installed the +virtual file system for the @acronym{GNOME} Desktop (GVFS), @ref{GVFS +based methods}. Internally, file archives are mounted via the GVFS +@option{archive} method. + +A file archive is a regular file of kind @file{/path/to/dir/file.EXT}. +The extension @samp{.EXT} identifies the type of the file archive. A +file inside a file archive, called archive file name, has the name +@file{/path/to/dir/file.EXT/dir/file}. + +Most of the @ref{Magic File Names, , magic file name operations, +elisp}, are implemented for archive file names, exceptions are all +operations which write into a file archive, and process related +operations. Therefore, functions like + +@lisp +(copy-file "/path/to/dir/file.tar/dir/file" "/somewhere/else") +@end lisp + +@noindent +work out of the box. This is also true for file name completion, and +for libraries like @code{dired} or @code{ediff}, which accept archive +file names as well. + +@vindex tramp-archive-suffixes +File archives are identified by the file name extension @samp{.EXT}. +Since GVFS uses internally the library @code{libarchive(3)}, all +suffixes, which are accepted by this library, work also for archive +file names. Accepted suffixes are listed in the constant +@code{tramp-archive-suffixes}. They are + +@itemize +@item @samp{.7z} --- +7-Zip archives +@cindex 7z, file archive suffix +@cindex file archive suffix 7z + +@item @samp{.apk} --- +Android package kits +@cindex apk, file archive suffix +@cindex file archive suffix apk + +@item @samp{.ar} --- +UNIX archiver formats +@cindex ar, file archive suffix +@cindex file archive suffix ar + +@item @samp{.cab}, @samp{.CAB} --- +Microsoft Windows cabinets +@cindex cab, file archive suffix +@cindex CAB, file archive suffix +@cindex file archive suffix cab +@cindex file archive suffix CAB + +@item @samp{.cpio} --- +CPIO archives +@cindex cpio, file archive suffix +@cindex file archive suffix cpio + +@item @samp{.deb} --- +Debian packages +@cindex deb, file archive suffix +@cindex file archive suffix deb + +@item @samp{.depot} --- +HP-UX SD depots +@cindex depot, file archive suffix +@cindex file archive suffix depot + +@item @samp{.exe} --- +Self extracting Microsoft Windows EXE files +@cindex exe, file archive suffix +@cindex file archive suffix exe + +@item @samp{.iso} --- +ISO 9660 images +@cindex iso, file archive suffix +@cindex file archive suffix iso + +@item @samp{.jar} --- +Java archives +@cindex jar, file archive suffix +@cindex file archive suffix jar + +@item @samp{.lzh}, @samp{LZH} --- +Microsoft Windows compressed LHA archives +@cindex lzh, file archive suffix +@cindex LZH, file archive suffix +@cindex file archive suffix lzh +@cindex file archive suffix LZH + +@item @samp{.mtree} --- +BSD mtree format +@cindex mtree, file archive suffix +@cindex file archive suffix mtree + +@item @samp{.pax} --- +Posix archives +@cindex pax, file archive suffix +@cindex file archive suffix pax + +@item @samp{.rar} --- +RAR archives +@cindex rar, file archive suffix +@cindex file archive suffix rar + +@item @samp{.rpm} --- +Red Hat packages +@cindex rpm, file archive suffix +@cindex file archive suffix rpm + +@item @samp{.shar} --- +Shell archives +@cindex shar, file archive suffix +@cindex file archive suffix shar + +@item @samp{.tar}, @samp{tbz}, @samp{tgz}, @samp{tlz}, @samp{txz} --- +(Compressed) tape archives +@cindex tar, file archive suffix +@cindex tbz, file archive suffix +@cindex tgz, file archive suffix +@cindex tlz, file archive suffix +@cindex txz, file archive suffix +@cindex file archive suffix tar +@cindex file archive suffix tbz +@cindex file archive suffix tgz +@cindex file archive suffix tlz +@cindex file archive suffix txz + +@item @samp{.warc} --- +Web archives +@cindex warc, file archive suffix +@cindex file archive suffix warc + +@item @samp{.xar} --- +macOS XAR archives +@cindex xar, file archive suffix +@cindex file archive suffix xar + +@item @samp{.xps} --- +Open XML Paper Specification (OpenXPS) documents +@cindex xps, file archive suffix +@cindex file archive suffix xps + +@item @samp{.zip}, @samp{.ZIP} --- +ZIP archives +@cindex zip, file archive suffix +@cindex ZIP, file archive suffix +@cindex file archive suffix zip +@cindex file archive suffix ZIP +@end itemize + +@vindex tramp-archive-compression-suffixes +File archives could also be compressed, identified by an additional +compression suffix. Valid compression suffixes are listed in the +constant @code{tramp-archive-compression-suffixes}. They are +@samp{.bz2}, @samp{.gz}, @samp{.lrz}, @samp{.lz}, @samp{.lz4}, +@samp{.lzma}, @samp{.lzo}, @samp{.uu}, @samp{.xz} and @samp{.Z}. A +valid archive file name would be +@file{/path/to/dir/file.tar.gz/dir/file}. Even several suffixes in a +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}. +Since all file operations are mapped internally to GVFS operations, +remote file names supported by @code{tramp-gvfs} perform better, +because no local copy of the file archive must be downloaded first. +For example, @samp{/sftp:user@@host:...} performs better than the +similar @samp{/scp:user@@host:...}. See the constant +@code{tramp-archive-all-gvfs-methods} for a complete list of +@code{tramp-gvfs} supported method names. + +If @value{tramp} is loaded and @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 +allows complex file operations like + +@lisp +@group +(progn + (require 'tramp) + (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" "")) +@end group +@end lisp + +It is even possible to access file archives in file archives, as + +@lisp +@group +(find-file + "http://ftp.debian.org/debian/pool/main/c/coreutils/coreutils_8.28-1_amd64.deb/control.tar.gz/control") +@end group +@end lisp + + @node Bug Reports @chapter Reporting Bugs and Problems @cindex bug reports @@ -2997,7 +3231,8 @@ Where is the latest @value{tramp}? @item Which systems does it work on? -The package works successfully on Emacs 24, Emacs 25, and Emacs 26. +The package works successfully on Emacs 24, Emacs 25, Emacs 26, and +Emacs 27. While Unix and Unix-like systems are the primary remote targets, @value{tramp} has equal success connecting to other platforms, such as diff --git a/doc/misc/trampver.texi b/doc/misc/trampver.texi index f81593fad37..eef2d9b6907 100644 --- a/doc/misc/trampver.texi +++ b/doc/misc/trampver.texi @@ -8,7 +8,7 @@ @c In the Tramp GIT, the version number is auto-frobbed from @c configure.ac, so you should edit that file and run @c "autoconf && ./configure" to change the version number. -@set trampver 2.3.3.26.1 +@set trampver 2.4.0-pre @c Other flags from configuration @set instprefix /usr/local diff --git a/etc/DEBUG b/etc/DEBUG index 81de77285a9..bb81414c817 100644 --- a/etc/DEBUG +++ b/etc/DEBUG @@ -140,9 +140,10 @@ If you attached the debugger to a running Emacs, type "continue" into the *gud-emacs* buffer and press RET. Many variables you will encounter while debugging are Lisp objects. -These are displayed as integer values (or structures, if you used the -"--enable-check-lisp-object-type" option at configure time) that are -hard to interpret, especially if they represent long lists. You can +These are normally displayed as opaque pointers or integers that are +hard to interpret, especially if they represent long lists. +(They are instead displayed as structures containing these opaque +values, if --enable-check-lisp-object-type is in effect.) You can use the 'pp' command to display them in their Lisp form. That command displays its output on the standard error stream, which you can redirect to a file using "M-x redirect-debugging-output". @@ -1,1475 +1,184 @@ GNU Emacs NEWS -- history of user-visible changes. -Copyright (C) 2016-2018 Free Software Foundation, Inc. +Copyright (C) 2017-2018 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 26. +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.25, NEWS.24, ..., NEWS.18, and NEWS.1-17 for changes +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 necessary documentation updates have been done. - (This means all the relevant manuals in doc/ AND lisp doc-strings.) ---- means doc strings are updated, and no change in the manuals is needed. ++++ indicates that all necessary documentation updates are complete. + (This means all relevant manuals in doc/ AND lisp doc-strings.) +--- means no change in the manuals is needed. When you add a new item, use the appropriate mark if you are sure it applies, -* Installation Changes in Emacs 26.1 - ---- -** By default libgnutls is now required when building Emacs. -Use 'configure --with-gnutls=no' to build even when GnuTLS is missing. - ---- -** GnuTLS version 2.12.2 or later is now required, instead of merely -version 2.6.6 or later. - -+++ -** The new option 'configure --with-mailutils' causes Emacs to rely on -GNU Mailutils to retrieve email. It is recommended, and is the -default if GNU Mailutils is installed. When --with-mailutils is not -in effect, the Emacs build procedure by default continues to build and -install a limited 'movemail' substitute that retrieves POP3 email only -via insecure channels. To avoid this problem, use either ---with-mailutils or --without-pop when configuring; --without-pop -is the default on platforms other than native MS-Windows. - ---- -** The new option 'configure --enable-gcc-warnings=warn-only' causes -GCC to issue warnings without stopping the build. This behavior is -now the default in developer builds. As before, use -'--disable-gcc-warnings' to suppress GCC's warnings, and -'--enable-gcc-warnings' to stop the build if GCC issues warnings. - ---- -** When GCC warnings are enabled, '--enable-check-lisp-object-type' is -now enabled by default when configuring. - -+++ -** The Emacs server now has socket-launching support. This allows -socket based activation, where an external process like systemd can -invoke the Emacs server process upon a socket connection event and -hand the socket over to Emacs. Emacs uses this socket to service -emacsclient commands. This new functionality can be disabled with the -configure option '--disable-libsystemd'. - -+++ -** A systemd user unit file is provided. Use it in the standard way: -'systemctl --user enable emacs'. -(If your Emacs is installed in a non-standard location, you may -need to copy the emacs.service file to eg ~/.config/systemd/user/) - ---- -** New configure option '--disable-build-details' attempts to build an -Emacs that is more likely to be reproducible; that is, if you build -and install Emacs twice, the second Emacs is a copy of the first. -Deterministic builds omit the build date from the output of the -'emacs-version' and 'erc-cmd-SV' functions, and the leave the -following variables nil: 'emacs-build-system', 'emacs-build-time', -'erc-emacs-build-time'. - ---- -** Emacs can now be built with support for Little CMS. - -If the lcms2 library is installed, Emacs will enable features built on -top of that library. The new configure option '--without-lcms2' can -be used to build without lcms2 support even if it is installed. Emacs -linked to Little CMS exposes color management functions in Lisp: the -color metrics 'lcms-cie-de2000' and 'lcms-cam02-ucs', as well as -functions for conversion to and from CIE CAM02 and CAM02-UCS. - ---- -** The configure option '--with-gameuser' now defaults to 'no', -as this appears to be the most common configuration in practice. -When it is 'no', the shared game directory and the auxiliary program -update-game-score are no longer needed and are not installed. - ---- -** Emacs no longer works on IRIX. We expect that Emacs users are not -affected by this, as SGI stopped supporting IRIX in December 2013. +* Installation Changes in Emacs 27.1 + +** The new configure option '--with-json' adds support for JSON using +the Jansson library. It 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. + +** 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 support -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. -* Startup Changes in Emacs 26.1 - -+++ -** New option '--fg-daemon'. This is the same as '--daemon', except -it runs in the foreground and does not fork. This is intended for -modern init systems such as systemd, which manage many of the traditional -aspects of daemon behavior themselves. '--bg-daemon' is now an alias -for '--daemon'. - -+++ -** New option '--module-assertions'. -When given this option, Emacs will perform expensive correctness -checks when dealing with dynamic modules. This is intended for module -authors that wish to verify that their module conforms to the module -requirements. The option makes Emacs abort if a module-related -assertion triggers. - -+++ -** Emacs now supports 24-bit colors on capable text terminals. -Terminal is automatically initialized to use 24-bit colors if the -required capabilities are found in terminfo. See the FAQ node -"(efaq) Colors on a TTY" for more information. - -+++ -** Emacs now obeys the X resource "scrollBar" at startup. -The effect is similar to that of "toolBar" resource on the tool bar. +* Startup Changes in Emacs 27.1 -* Changes in Emacs 26.1 - -+++ -** Option 'buffer-offer-save' can be set to new value, 'always'. When -set to 'always', the command 'save-some-buffers' will always offer -this buffer for saving. - -** Security vulnerability related to Enriched Text mode is removed. - -+++ -*** Enriched Text mode does not evaluate Lisp in 'display' properties. -This feature allows saving 'display' properties as part of text. -Emacs 'display' properties support evaluation of arbitrary Lisp forms -as part of processing the property for display, so displaying Enriched -Text could be vulnerable to executing arbitrary malicious Lisp code -included in the text (e.g., sent as part of an email message). -Therefore, execution of arbitrary Lisp forms in 'display' properties -decoded by Enriched Text mode is now disabled by default. Customize -the new option 'enriched-allow-eval-in-display-props' to a non-nil -value to allow Lisp evaluation in decoded 'display' properties. - -This vulnerability was introduced in Emacs 21.1. To work around that -in Emacs versions before 25.3, append the following to your ~/.emacs -init file: - - (eval-after-load "enriched" - '(defun enriched-decode-display-prop (start end &optional param) - (list start end))) - -+++ -** Functions in 'write-contents-functions' can fully short-circuit the -'save-buffer' process. Previously, saving a buffer that was not -visiting a file would always prompt for a file name. Now it only does -so if 'write-contents-functions' is nil (or all its functions return -nil). - ---- -** New variable 'executable-prefix-env' for inserting magic signatures. -This variable affects the format of the interpreter magic number -inserted by 'executable-set-magic'. If non-nil, the magic number now -takes the form "#!/usr/bin/env interpreter", otherwise the value -determined by 'executable-prefix', which is by default -"#!/path/to/interpreter". By default, 'executable-prefix-env' is nil, -so the default behavior is not changed. - -+++ -** The variable 'emacs-version' no longer includes the build number. -This is now stored separately in a new variable, 'emacs-build-number'. - -+++ -** Emacs now provides a limited form of concurrency with Lisp threads. -Concurrency in Emacs Lisp is "mostly cooperative", meaning that -Emacs will only switch execution between threads at well-defined -times: when Emacs waits for input, during blocking operations related -to threads (such as mutex locking), or when the current thread -explicitly yields. Global variables are shared among all threads, but -a 'let' binding is thread-local. Each thread also has its own current -buffer and its own match data. - -See the chapter "(elisp) Threads" in the ELisp manual for full -documentation of these facilities. - -+++ -** The new user variable 'electric-quote-chars' provides a list -of curved quotes for 'electric-quote-mode', allowing user to choose -the types of quotes to be used. - ---- -** The new user option 'electric-quote-context-sensitive' makes -'electric-quote-mode' context sensitive. If it is non-nil, you can -type an ASCII apostrophe to insert an opening or closing quote, -depending on context. Emacs will replace the apostrophe by an opening -quote character at the beginning of the buffer, the beginning of a -line, after a whitespace character, and after an opening parenthesis; -and it will replace the apostrophe by a closing quote character in all -other cases. - ---- -** The new variable 'electric-quote-inhibit-functions' controls when -to disable electric quoting based on context. Major modes can add -functions to this list; Emacs will temporarily disable -'electric-quote-mode' whenever any of the functions returns non-nil. -This can be used by major modes that derive from 'text-mode' but allow -inline code segments, such as 'markdown-mode'. - -+++ -** The new user variable 'dired-omit-case-fold' allows the user to -customize the case-sensitivity of dired-omit-mode. It defaults to -the same sensitivity as that of the filesystem for the corresponding -dired buffer. - -+++ -** Emacs now uses double buffering to reduce flicker when editing and -resizing graphical Emacs frames on the X Window System. This support -requires the DOUBLE-BUFFER extension, which major X servers have -supported for many years. If your system has this extension, but an -Emacs built with double buffering misbehaves on some displays you use, -you can disable the feature by adding - - '(inhibit-double-buffering . t) - -to default-frame-alist. Or inject this parameter into the selected -frame by evaluating this form: - - (modify-frame-parameters nil '((inhibit-double-buffering . t))) - ---- -** The customization group 'wp', whose label was "text", is now -deprecated. Use the new group 'text', which inherits from 'wp', -instead. - -+++ -** The new function 'call-shell-region' executes a command in an -inferior shell with the buffer region as input. - -+++ -** The new user option 'shell-command-dont-erase-buffer' controls -if the output buffer is erased between shell commands; if non-nil, -the output buffer is not erased; this variable also controls where -to set the point in the output buffer: beginning of the output, -end of the buffer or save the point. -When 'shell-command-dont-erase-buffer' is nil, the default value, -the behavior of 'shell-command', 'shell-command-on-region' and -'async-shell-command' is as usual. - -+++ -** The new user option 'async-shell-command-display-buffer' controls -whether the output buffer of an asynchronous command is shown -immediately, or only when there is output. - -+++ -** New user option 'mouse-select-region-move-to-beginning'. -This option controls the position of point when double-clicking -mouse-1 on the end of a parenthetical grouping or string-delimiter: -the default value nil keeps point at the end of the region, setting it -to non-nil moves point to the beginning of the region. - -+++ -** New user option 'mouse-drag-and-drop-region'. -This option allows to drag the entire region of text to another place -or another buffer. Its behavior is customizable via the new options -'mouse-drag-and-drop-region-cut-when-buffers-differ', -'mouse-drag-and-drop-region-show-tooltip', and -'mouse-drag-and-drop-region-show-cursor'. - -+++ -** The new user option 'confirm-kill-processes' allows the user to -skip a confirmation prompt for killing subprocesses when exiting -Emacs. When set to t (the default), Emacs will prompt for -confirmation before killing subprocesses on exit, which is the same -behavior as before. - ---- -** 'find-library-name' will now fall back on looking at 'load-history' -to try to locate libraries that have been loaded with an explicit path -outside 'load-path'. - -+++ -** Faces in 'minibuffer-prompt-properties' no longer overwrite properties -in the text in functions like 'read-from-minibuffer', but instead are -added to the end of the face list. This allows users to say things -like '(read-from-minibuffer (propertize "Enter something: " 'face 'bold))'. - -+++ -** The new variable 'extended-command-suggest-shorter' has been added -to control whether to suggest shorter 'M-x' commands or not. - ---- -** icomplete now respects 'completion-ignored-extensions'. - -+++ -** Non-breaking hyphens are now displayed with the 'nobreak-hyphen' -face instead of the 'escape-glyph' face. - -+++ -** Approximations to quotes are now displayed with the new 'homoglyph' -face instead of the 'escape-glyph' face. - -+++ -** New face 'header-line-highlight'. -This face is the header-line analogue of 'mode-line-highlight'; it -should be the preferred mouse-face for mouse-sensitive elements in the -header line. - ---- -** 'C-x h' ('mark-whole-buffer') will now avoid marking the prompt -part of minibuffers. - ---- -** 'fill-paragraph' no longer marks the buffer as changed unless it -actually changed something. - ---- -** The locale language name 'ca' is now mapped to the language -environment 'Catalan', which has been added. - ---- -** 'align-regexp' has a separate history for its interactive argument. -'align-regexp' no longer shares its history with all other -history-less functions that use 'read-string'. - -+++ -** The networking code has been reworked so that it's more -asynchronous than it was (when specifying :nowait t in -'make-network-process'). How asynchronous it is varies based on the -capabilities of the system, but on a typical GNU/Linux system the DNS -resolution, the connection, and (for TLS streams) the TLS negotiation -are all done without blocking the main Emacs thread. To get -asynchronous TLS, the TLS boot parameters have to be passed in (see -the manual for details). - -Certain process oriented functions (like 'process-datagram-address') -will block until socket setup has been performed. The recommended way -to deal with asynchronous sockets is to avoid interacting with them -until they have changed status to "run". This is most easily done -from a process sentinel. - ---- -** 'make-network-process' and 'open-network-stream' sometimes allowed -:service to be an integer string (e.g., :service "993") and sometimes -required an integer (e.g., :service 993). This difference has been -eliminated, and integer strings work everywhere. +* Changes in Emacs 27.1 --- -** It is possible to disable attempted recovery on fatal signals. -Two new variables support disabling attempts to recover from stack -overflow and to avoid automatic auto-save when Emacs is delivered a -fatal signal. 'attempt-stack-overflow-recovery', if set to nil, -will disable attempts to recover from C stack overflows; Emacs will -then crash as with any other fatal signal. -'attempt-orderly-shutdown-on-fatal-signal', if set to nil, will -disable attempts to auto-save the session and shut down in an orderly -fashion when Emacs receives a fatal signal; instead, Emacs will -terminate immediately. Both variables are non-nil by default. -These variables are for users who would like to avoid the small -probability of data corruption due to techniques Emacs uses to recover -in these situations. - -+++ -** File local and directory local variables are now initialized each -time the major mode is set, not just when the file is first visited. -These local variables will thus not vanish on setting a major mode. - -+++ -** A second dir-local file (.dir-locals-2.el) is now accepted. -See the doc string of 'dir-locals-file' for more information. - -+++ -** Connection-local variables can be used to specify local variables -with a value depending on the connected remote server. For details, -see the node "(elisp) Connection Local Variables" in the ELisp manual. - ---- -** International domain names (IDNA) are now encoded via the new -puny.el library, so that one can visit Web sites with non-ASCII URLs. - -+++ -** The new 'list-timers' command lists all active timers in a buffer, -where you can cancel them with the 'c' command. - -+++ -** 'switch-to-buffer-preserve-window-point' now defaults to t. -Applications that call 'switch-to-buffer' and want to show the buffer at -the position of its point should use 'pop-to-buffer-same-window' in lieu -of 'switch-to-buffer'. - -+++ -** The new variable 'debugger-stack-frame-as-list' allows displaying -all call stack frames in a Lisp backtrace buffer as lists. Both -debug.el and edebug.el have been updated to heed to this variable. - ---- -** Values in call stack frames are now displayed using 'cl-prin1'. -The old behavior of using 'prin1' can be restored by customizing the -new option 'debugger-print-function'. - -+++ -** NUL bytes in text copied to the system clipboard are now replaced with "\0". - -+++ -** The new variable 'x-ctrl-keysym' has been added to the existing -roster of X keysyms. It can be used in combination with another -variable of this kind to swap modifiers in Emacs. - ---- -** New input methods: 'cyrillic-tuvan', 'polish-prefix', 'uzbek-cyrillic'. - ---- -** The 'dutch' input method no longer attempts to support Turkish too. -Also, it no longer converts 'IJ' and 'ij' to the compatibility -characters U+0132 LATIN CAPITAL LIGATURE IJ and U+0133 LATIN SMALL -LIGATURE IJ. - -+++ -** File name quoting by adding the prefix "/:" is now possible for the -local part of a remote file name. Thus, if you have a directory named -"/~" on the remote host "foo", you can prevent it from being -substituted by a home directory by writing it as "/foo:/:/~/file". - -+++ -** The new variable 'maximum-scroll-margin' allows having effective -settings of 'scroll-margin' up to half the window size, instead of -always restricting the margin to a quarter of the window. - -+++ -** Emacs can scroll horizontally using mouse, touchpad, and trackbar. -You can enable this by customizing 'mwheel-tilt-scroll-p'. If you -want to reverse the direction of the scroll, customize -'mwheel-flip-direction'. - -+++ -** The default GnuTLS priority string now includes %DUMBFW. -This is to avoid bad behavior in some firewalls, which causes the -connection to be closed by the remote host. - -** Emacsclient changes +** The new 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. +++ -*** Emacsclient has a new option '-u' / '--suppress-output'. -This option suppresses display of return values from the server -process. +** New function 'logcount' calculates an integer's Hamming weight. +++ -*** Emacsclient has a new option '-T' / '--tramp'. -This helps with using a local Emacs session as the server for a remote -emacsclient. With appropriate setup, one can now set the EDITOR -environment variable on a remote machine to emacsclient, and -use the local Emacs to edit remote files via Tramp. See the node -"(emacs) emacsclient Options" in the user manual for the details. - -+++ -*** Emacsclient now accepts command-line options in ALTERNATE_EDITOR -and '--alternate-editor'. For example, ALTERNATE_EDITOR="emacs -Q -nw". -Arguments may be quoted "like this", so that for example an absolute -path containing a space may be specified; quote escaping is not -supported. - ---- -** New user option 'dig-program-options' and extended functionality -for DNS-querying functions 'nslookup-host', 'dns-lookup-host', -and 'run-dig'. Each function now accepts an optional name server -argument interactively (with a prefix argument) and non-interactively. - -+++ -** 'describe-key-briefly' now ignores mouse movement events. - -+++ -** The new variable 'eval-expression-print-maximum-character' prevents -large integers from being displayed as characters by 'M-:' and similar -commands. - ---- -** Two new commands for finding the source code of Emacs Lisp -libraries: 'find-library-other-window' and 'find-library-other-frame'. - -+++ -** The new variable 'display-raw-bytes-as-hex' allows to change the -display of raw bytes from octal to hex. - -+++ -** You can now provide explicit field numbers in format specifiers. -For example, '(format "%2$s %1$s %2$s" "X" "Y")' produces "Y X Y". - -+++ -** Emacs now supports optional display of line numbers in the buffer. -This is similar to what 'linum-mode' provides, but much faster and -doesn't usurp the display margin for the line numbers. Customize the -buffer-local variable 'display-line-numbers' to activate this optional -display. Alternatively, you can use the 'display-line-numbers-mode' -minor mode or the global 'global-display-line-numbers-mode'. When -using these modes, customize 'display-line-numbers-type' with the same -value as you would use with 'display-line-numbers'. - -Line numbers are not displayed at all in minibuffer windows and in -tooltips, as they are not useful there. - -Lisp programs can disable line-number display for a particular screen -line by putting the 'display-line-numbers-disable' text property or -overlay property on the first character of that screen line. This is -intended for add-on packages that need a finer control of the display. - -Lisp programs that need to know how much screen estate is used up for -line-number display in a window can use the new function -'line-number-display-width'. - -'linum-mode' and all similar packages are henceforth becoming obsolete. -Users and developers are encouraged to switch to this new feature -instead. - ---- -** The new user option 'arabic-shaper-ZWNJ-handling' controls how to -handle ZWNJ in Arabic text rendering. +** 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. -* Editing Changes in Emacs 26.1 - -+++ -** New variable 'column-number-indicator-zero-based'. -Traditionally, in Column Number mode, the displayed column number -counts from zero starting at the left margin of the window. This -behavior is now controlled by 'column-number-indicator-zero-based'. -If you would prefer for the displayed column number to count from one, -you may set this variable to nil. (Behind the scenes, there is now a -new mode line construct, '%C', which operates exactly as '%c' does -except that it counts from one.) - -+++ -** New single-line horizontal scrolling mode. -The 'auto-hscroll-mode' variable can now have a new special value, -'current-line', which causes only the line where the cursor is -displayed to be horizontally scrolled when lines are truncated on -display and point moves outside the left or right window margin. - -+++ -** New mode line constructs '%o' and '%q', and user option -'mode-line-percent-position'. '%o' displays the "degree of travel" of -the window through the buffer. Unlike the default '%p', this -percentage approaches 100% as the window approaches the end of the -buffer. '%q' displays the percentage offsets of both the start and -the end of the window, e.g. "5-17%". The new option -'mode-line-percent-position' makes it easier to switch between '%p', -'%P', and these new constructs. - -+++ -** Two new user options 'list-matching-lines-jump-to-current-line' and -'list-matching-lines-current-line-face' to show the current line -highlighted in *Occur* buffer. - -+++ -** The 'occur' command can now operate on the region. - -+++ -** New bindings for 'query-replace-map'. -'undo', undo the last replacement; bound to 'u'. -'undo-all', undo all replacements; bound to 'U'. - ---- -** 'delete-trailing-whitespace' deletes whitespace after form feed. -In modes where form feed was treated as a whitespace character, -'delete-trailing-whitespace' would keep lines containing it unchanged. -It now deletes whitespace after the last form feed thus behaving the -same as in modes where the character is not whitespace. - ---- -** Emacs no longer prompts about editing a changed file when the file's -content is unchanged. Instead of only checking the modification time, -Emacs now also checks the file's actual content before prompting the user. - ---- -** Various casing improvements. - -*** 'upcase', 'upcase-region' et al. convert title case characters -(such as Dz) into their upper case form (such as DZ). - -*** 'capitalize', 'upcase-initials' et al. make use of title-case forms -of initial characters (correctly producing for example Džungla instead -of incorrect DŽungla). - -*** Characters which turn into multiple ones when cased are correctly handled. -For example, fi ligature is converted to FI when upper cased. - -*** Greek small sigma is correctly handled when at the end of the word. -Strings such as ΌΣΟΣ are now correctly converted to Όσος when -capitalized instead of incorrect Όσοσ (compare lowercase sigma at the -end of the word). - -+++ -** Emacs can now auto-save buffers to visited files in a more robust -manner via the new mode 'auto-save-visited-mode'. Unlike -'auto-save-visited-file-name', this mode uses the normal saving -procedure and therefore obeys saving hooks. -'auto-save-visited-file-name' is now obsolete. - -+++ -** New behavior of 'mark-defun'. -Prefix argument selects that many (or that many more) defuns. -Negative prefix arg flips the direction of selection. Also, -'mark-defun' between defuns correctly selects N following defuns (or --N previous for negative arguments). Finally, comments preceding the -defun are selected unless they are separated from the defun by a blank -line. - ---- -** New command 'replace-buffer-contents'. -This command replaces the contents of the accessible portion of the -current buffer with the contents of the accessible portion of a -different buffer while keeping point, mark, markers, and text -properties as intact as possible. - -+++ -** New commands 'apropos-local-variable' and 'apropos-local-value'. -These are buffer-local versions of 'apropos-variable' and -'apropos-value', respectively. They show buffer-local variables whose -names and values, respectively, match a given pattern. - -+++ -** More user control of reordering bidirectional text for display. -The two new variables, 'bidi-paragraph-start-re' and -'bidi-paragraph-separate-re', allow customization of what exactly are -paragraphs, for the purposes of bidirectional display. +* Editing Changes in Emacs 27.1 --- ** 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). - -* Changes in Specialized Modes and Packages in Emacs 26.1 - ---- -** Emacs 26.1 comes with Org v9.1.4. -See the file ORG-NEWS for user-visible changes in Org. - ---- -** New function 'cl-generic-p'. - -** Dired - -+++ -*** You can answer 'all' in 'dired-do-delete' to delete recursively all -remaining directories without more prompts. - -+++ -*** Dired supports wildcards in the directory part of the file names. - -+++ -*** You can now use '`?`' in 'dired-do-shell-command'. -It gets replaced by the current file name, like ' ? '. - -+++ -*** A new option 'dired-always-read-filesystem' defaulting to nil. -If non-nil, buffers visiting files are reverted before they are -searched; for instance, in 'dired-mark-files-containing-regexp' a -non-nil value of this option means the file is revisited in a -temporary buffer; this temporary buffer is the actual buffer searched: -the original buffer visiting the file is not modified. - ---- -*** Users can now customize mouse clicks in Dired in a more flexible way. -The new command 'dired-mouse-find-file' can be bound to a mouse click -and used to visit files/directories in Dired in the selected window. -The new command 'dired-mouse-find-file-other-frame' similarly visits -files/directories in another frame. You can write your own commands -that invoke 'dired-mouse-find-file' with non-default optional -arguments, to tailor the effects of mouse clicks on file names in -Dired buffers. - -+++ -*** In wdired, when editing files to contain slash characters, -the resulting directories are automatically created. Whether to do -this is controlled by the 'wdired-create-parent-directories' variable. - -+++ -*** 'W' is now bound to 'browse-url-of-dired-file', and is useful for -viewing HTML files and the like. - ---- -*** New variable 'dired-clean-confirm-killing-deleted-buffers' -controls whether Dired asks to kill buffers visiting deleted files and -directories. The default is t, so Dired asks for confirmation, to -keep previous behavior. - ---- -** html2text is now marked obsolete. - ---- -** smerge-refine-regions can refine regions in separate buffers. - ---- -** Info menu and index completion uses substring completion by default. -This can be customized via the 'info-menu' category in -'completion-category-overrides'. - -+++ -** The ancestor buffer is shown by default in 3-way merges. -A new option 'ediff-show-ancestor' and a new toggle -'ediff-toggle-show-ancestor'. - ---- -** TeX: Add luatex and xetex as alternatives to pdftex - -** Electric-Buffer-menu - +++ -*** Key 'U' is bound to 'Buffer-menu-unmark-all' and key 'M-DEL' is -bound to 'Buffer-menu-unmark-all-buffers'. +** 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 and +strings in non-text modes. -+++ -** hideshow mode got four key bindings that are analogous to outline -mode bindings: 'C-c @ C-a', 'C-c @ C-t', 'C-c @ C-d', and 'C-c @ C-e'. - -** bs - ---- -*** Two new commands 'bs-unmark-all', bound to 'U', and -'bs-unmark-previous', bound to <backspace>. - -** Buffer-menu - -+++ -*** Two new commands 'Buffer-menu-unmark-all', bound to 'U' and -'Buffer-menu-unmark-all-buffers', bound to 'M-DEL'. - ---- -** Checkdoc + +* Changes in Specialized Modes and Packages in Emacs 27.1 -*** 'checkdoc-arguments-in-order-flag' now defaults to nil. +** Footnote-mode +*** Support Hebrew-style footnotes +*** Footnote text lines are now aligned. +Can be controlled via the new variable 'footnote-align-to-fn-text'. -** Gnus +** CSS mode --- -*** The ~/.newsrc file will now only be saved if the native select -method is an NNTP select method. +*** 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'. -+++ -*** A new command for sorting articles by readedness marks has been -added: 'C-c C-s C-m C-m'. +** Dired +++ -*** In 'message-citation-line-format' the '%Z' format is now the time -zone name instead of the numeric form. The '%z' format continues to -be the numeric form. The new behavior is compatible with -'format-time-string'. +*** 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. ** Ibuffer --- -*** New command 'ibuffer-jump'. - ---- -*** New filter commands 'ibuffer-filter-by-basename', -'ibuffer-filter-by-file-extension', 'ibuffer-filter-by-directory', -'ibuffer-filter-by-starred-name', 'ibuffer-filter-by-modified' -and 'ibuffer-filter-by-visiting-file'; bound respectively -to '/b', '/.', '//', '/*', '/i' and '/v'. - ---- -*** Two new commands 'ibuffer-filter-chosen-by-completion' -and 'ibuffer-and-filter', the second bound to '/&'. - ---- -*** The commands 'ibuffer-pop-filter', 'ibuffer-pop-filter-group', -'ibuffer-or-filter' and 'ibuffer-filter-disable' have the alternative -bindings '/<up>', '/S-<up>', '/|' and '/DEL', respectively. - ---- -*** The data format specifying filters has been extended to allow -explicit logical 'and', and a more flexible form for logical 'not'. -See 'ibuffer-filtering-qualifiers' doc string for full details. - ---- -*** A new command 'ibuffer-copy-buffername-as-kill'; bound -to 'B'. - ---- -*** New command 'ibuffer-change-marks'; bound to '* c'. - ---- -*** A new command 'ibuffer-mark-by-locked' to mark -all locked buffers; bound to '% L'. - ---- -*** A new option 'ibuffer-locked-char' to indicate -locked buffers; Ibuffer shows a new column displaying -'ibuffer-locked-char' for locked buffers. - ---- -*** A new command 'ibuffer-unmark-all-marks' to unmark -all buffers without asking confirmation; bound to -'U'; 'ibuffer-do-replace-regexp' bound to 'r'. - ---- -*** A new command 'ibuffer-mark-by-content-regexp' to mark buffers -whose content matches a regexp; bound to '% g'. - ---- -*** Two new options 'ibuffer-never-search-content-name' and -'ibuffer-never-search-content-mode' used by -'ibuffer-mark-by-content-regexp'. - -** Browse-URL - ---- -*** Support for opening links to man pages in Man or WoMan mode. - -** Comint - ---- -*** New user option 'comint-move-point-for-matching-input' to control -where to place point after 'C-c M-r' and 'C-c M-s'. - -+++ -*** New user option 'comint-terminfo-terminal'. -This option allows control of the value of the TERM environment -variable Emacs puts into the environment of the Comint mode and its -derivatives, such as Shell mode and Compilation Shell minor-mode. The -default is "dumb", for compatibility with previous behavior. - -** Compilation mode - ---- -*** Messages from CMake are now recognized. - -+++ -*** The number of errors, warnings, and informational messages is now -displayed in the mode line. These are updated as compilation -proceeds. - -** Grep - ---- -*** Grep commands will now use GNU grep's '--null' option if -available, which allows distinguishing the filename from contents if -they contain colons. This can be controlled by the new custom option -'grep-use-null-filename-separator'. - ---- -*** The grep/rgrep/lgrep functions will now ask about saving files -before running. This is controlled by the 'grep-save-buffers' -variable. +*** New filter ibuffer-filter-by-process; bound to '/E'. ** Edebug ---- -*** Edebug can be prevented from pausing 1 second after reaching a -breakpoint (e.g. with "f" and "o") by customizing the new option -'edebug-sit-on-break'. - +++ -*** New customizable option 'edebug-max-depth'. -This allows to enlarge the maximum recursion depth when instrumenting -code. +*** 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. -** Eshell +** Enhanced xterm support ---- -*** 'eshell-input-filter's value is now a named function -'eshell-input-filter-default', and has a new custom option -'eshell-input-filter-initial-space' to ignore adding commands prefixed -with blank space to eshell history. - -** EUDC - ---- -*** Backward compatibility support for BBDB versions less than 3 -(i.e., BBDB 2.x) is deprecated and will likely be removed in the next -major release of Emacs. Users of BBDB 2.x should plan to upgrade to -BBDB 3.x. +*** New variable 'xterm-set-window-title' controls whether Emacs sets +the XTerm window title. This feature is experimental and is disabled +by default. -** eww +** Gamegrid -+++ -*** New 'M-RET' command for opening a link at point in a new eww buffer. +** ERT +++ -*** A new 's' command for switching to another eww buffer via the minibuffer. - ---- -*** The 'o' command ('shr-save-contents') has moved to 'O' to avoid collision -with the 'o' command from 'image-map'. - -+++ -*** A new command 'C' ('eww-toggle-colors') can be used to toggle -whether to use the HTML-specified colors or not. The user can also -customize the 'shr-use-colors' variable. - ---- -*** Images that are being loaded are now marked with gray -"placeholder" images of the size specified by the HTML. They are then -replaced by the real images asynchronously, which will also now -respect width/height HTML specs (unless they specify widths/heights -bigger than the current window). +*** New variable 'ert-quiet' allows to make ERT output in batch mode +less verbose by removing non-essential information. --- -*** The 'w' command on links is now 'shr-maybe-probe-and-copy-url'. -'shr-copy-url' now only copies the url at point; users who wish to -avoid accidentally accessing remote links may rebind 'w' and 'u' in -'eww-link-keymap' to it. +*** 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 more playable on HiDPI displays. -** Ido +** Filecache --- -*** The commands 'find-alternate-file-other-window', -'dired-other-window', 'dired-other-frame', and -'display-buffer-other-window' are now remapped to Ido equivalents if -Ido mode is active. +*** Completing filenames in the minibuffer via 'C-TAB' now uses the +styles as configured by the variable 'completion-styles'. -** Images +** New macros 'thunk-let' and 'thunk-let*'. +These macros are analogue to 'let' and 'let*', but create bindings that +are evaluated lazily. -+++ -*** Images are automatically scaled before displaying based on the -'image-scaling-factor' variable (if Emacs supports scaling the images -in question). - -+++ -*** It's now possible to specify aspect-ratio preserving combinations -of :width/:max-height and :height/:max-width keywords. In either -case, the "max" keywords win. (Previously some combinations would, -depending on the aspect ratio of the image, just be ignored and in -other instances this would lead to the aspect ratio not being -preserved.) - -+++ -*** Images inserted with 'insert-image' and related functions get a -keymap put into the text properties (or overlays) that span the -image. This keymap binds keystrokes for manipulating size and -rotation, as well as saving the image to a file. These commands are -also available in 'image-mode'. - -+++ -*** A new library for creating and manipulating SVG images has been -added. See the "(elisp) SVG Images" section in the ELisp reference -manual for details. - -+++ -*** New setf-able function to access and set image parameters is -provided: 'image-property'. - ---- -*** New commands 'image-scroll-left' and 'image-scroll-right' -for 'image-mode' that complement 'image-scroll-up' and -'image-scroll-down': they have the same prefix arg behavior and stop -at image boundaries. - -** Image-Dired - ---- -*** Now provides a minor mode 'image-dired-minor-mode' which replaces -the function 'image-dired-setup-dired-keybindings'. - ---- -*** Thumbnail generation is now asynchronous. -The number of concurrent processes is limited by the variable -'image-dired-thumb-job-limit'. - ---- -*** 'image-dired-thumbnail-storage' has a new option 'standard-large' -for generating 256x256 thumbnails according to the Thumbnail Managing -Standard. - ---- -*** Inherits movement keys from 'image-mode' for viewing full images. -This includes the usual char, line, and page movement commands. - ---- -*** All the -options types have been changed to argument lists -instead of shell command strings. This change affects -'image-dired-cmd-create-thumbnail-options', -'image-dired-cmd-create-temp-image-options', -'image-dired-cmd-rotate-thumbnail-options', -'image-dired-cmd-rotate-original-options', -'image-dired-cmd-write-exif-data-options', -'image-dired-cmd-read-exif-data-options', and introduces -'image-dired-cmd-pngnq-options', 'image-dired-cmd-pngcrush-options', -'image-dired-cmd-create-standard-thumbnail-options'. - ---- -*** Recognizes more tools by default, including pngnq-s9 and OptiPNG. - ---- -*** 'find-file' and related commands now work on thumbnails and -displayed images, providing a default argument of the original file name -via an addition to 'file-name-at-point-functions'. - ---- -** The default 'Info-default-directory-list' no longer checks some obsolete -directory suffixes (gnu, gnu/lib, gnu/lib/emacs, emacs, lib, lib/emacs) -when searching for info directories. - -+++ -** The commands that add ChangeLog entries now prefer a VCS root directory -for the ChangeLog file, if none already exists. Customize -'change-log-directory-files' to nil for the old behavior. - ---- -** Support for non-string values of 'time-stamp-format' has been removed. - -** Message - ---- -*** 'message-use-idna' now defaults to t (because Emacs comes with -built-in IDNA support now). - ---- -*** When sending HTML messages with embedded images, and you have -exiftool installed, and you rotate images with EXIF data (i.e., -JPEGs), the rotational information will be inserted into the outgoing -image in the message. (The original image will not have its -orientation affected.) - ---- -*** The 'message-valid-fqdn-regexp' variable has been removed, since -there are now top-level domains added all the time. Message will no -longer warn about sending emails to top-level domains it hasn't heard -about. +** Eshell --- -*** 'message-beginning-of-line' (bound to 'C-a') understands folded headers. -In 'visual-line-mode' it will look for the true beginning of a header -while in non-'visual-line-mode' it will move the point to the indented -header's value. - -** Package +*** Expansion of history event designators is disabled by default. +To restore the old behavior, use -+++ -*** The new variable 'package-gnupghome-dir' has been added to control -where the GnuPG home directory (used for signature verification) is -located and whether GnuPG's option '--homedir' is used or not. - ---- -*** Deleting a package no longer respects 'delete-by-moving-to-trash'. + (add-hook 'eshell-expand-input-functions + #'eshell-expand-history-references) ** Tramp +++ -*** The method part of remote file names is mandatory now. -A valid remote file name starts with "/method:host:" or -"/method:user@host:". - -+++ -*** The new pseudo method "-" is a marker for the default method. -"/-::" is the shortest remote file name then. - -+++ -*** The command 'tramp-change-syntax' allows to choose an alternative -remote file name syntax. - -+++ -*** New connection method "sg", which supports editing files under a -different group ID. - -+++ -*** New connection method "doas" for OpenBSD hosts. - -+++ -*** New connection method "gdrive", which allows to access Google -Drive onsite repositories. - -+++ -*** Gateway methods in Tramp have been removed. -Instead, the Tramp manual documents how to configure ssh and PuTTY -accordingly. - -+++ -*** Setting the "ENV" environment variable in -'tramp-remote-process-environment' enables reading of shell -initialization files. - ---- -*** Tramp is able now to send SIGINT to remote asynchronous processes. - ---- -*** Variable 'tramp-completion-mode' is obsoleted. - ---- -** 'auto-revert-use-notify' is set back to t in 'global-auto-revert-mode'. - -** JS mode - ---- -*** JS mode now sets 'comment-multi-line' to t. - ---- -*** New variable 'js-indent-align-list-continuation', when set to nil, -will not align continuations of bracketed lists, but will indent them -by the fixed width 'js-indent-level'. - -** CSS mode - ---- -*** Support for completing attribute values, at-rules, bang-rules, -HTML tags, classes and IDs using the 'completion-at-point' command. -Completion candidates for HTML classes and IDs are retrieved from open -HTML mode buffers. - ---- -*** CSS mode now binds 'C-h S' to a function that will show -information about a CSS construct (an at-rule, property, pseudo-class, -pseudo-element, with the default being guessed from context). By -default the information is looked up on the Mozilla Developer Network, -but this can be customized using 'css-lookup-url-format'. - ---- -*** CSS colors are fontified using the color they represent as the -background. For instance, #ff0000 would be fontified with a red -background. - -+++ -** Emacs now supports character name escape sequences in character and -string literals. The syntax variants '\N{character name}' and -'\N{U+code}' are supported. - -+++ -** Prog mode has some support for multi-mode indentation. -This allows better indentation support in modes that support multiple -programming languages in the same buffer, like literate programming -environments or ANTLR programs with embedded Python code. - -A major mode can provide indentation context for a sub-mode. To -support this, modes should use 'prog-first-column' instead of a -literal zero and avoid calling 'widen' in their indentation functions. -See the node "(elisp) Mode-Specific Indent" in the ELisp manual for -more details. - -** ERC - ---- -*** New variable 'erc-default-port-tls' used to connect to TLS IRC -servers. - -** URL - -+++ -*** The new function 'url-cookie-delete-cookie' can be used to -programmatically delete all cookies, or cookies from a specific -domain. - -+++ -*** 'url-retrieve-synchronously' now takes an optional timeout parameter. - ---- -*** The URL package now supports HTTPS over proxies supporting CONNECT. - -+++ -*** 'url-user-agent' now defaults to 'default', and the User-Agent -string is computed dynamically based on 'url-privacy-level'. - -** VC and related modes - -+++ -*** 'vc-dir-mode' now binds 'vc-log-outgoing' to 'O'; and has various -branch-related commands on a keymap bound to 'B'. - -+++ -*** 'vc-region-history' is now bound to 'C-x v h', replacing the older -'vc-insert-headers' binding. - -** CC mode - ---- -*** Opening a .h file will turn C or C++ mode depending on language used. -This is done with the help of the 'c-or-c++-mode' function, which -analyzes buffer contents to infer whether it's a C or C++ source file. - ---- -** New option 'cpp-message-min-time-interval' to allow user control -of progress messages in cpp.el. - ---- -** New DNS mode command 'dns-mode-ipv6-to-nibbles' to convert IPv6 addresses -to a format suitable for reverse lookup zone files. - -** Ispell - -+++ -*** Enchant is now supported as a spell-checker. - -Enchant is a meta-spell-checker that uses providers such as Hunspell -to do the actual checking. With it, users can use spell-checkers not -directly supported by Emacs, such as Voikko, Hspell and AppleSpell, -more easily share personal word-lists with other programs, and -configure different spelling-checkers for different languages. -(Version 2.1.0 or later of Enchant is required.) - -** Flymake - -+++ -*** Flymake has been completely redesigned - -Flymake now annotates arbitrary buffer regions, not just lines. It -supports arbitrary diagnostic types, not just errors and warnings (see -variable 'flymake-diagnostic-types-alist'). - -It also supports multiple simultaneous backends, meaning that you can -check your buffer from different perspectives (see variable -'flymake-diagnostic-functions'). Backends for Emacs Lisp mode are -provided. - -The old Flymake behavior is preserved in the so-called "legacy -backend", which has been updated to benefit from the new UI features. - -** Term - ---- -*** `term-char-mode' now makes its buffer read-only. - -The buffer is made read-only to prevent changes from being made by -anything other than the process filter; and movements of point away -from the process mark are counter-acted so that the cursor is in the -correct position after each command. This is needed to avoid states -which are inconsistent with the state of the terminal understood by -the inferior process. - -New user options `term-char-mode-buffer-read-only' and -`term-char-mode-point-at-process-mark' control these behaviors, and -are non-nil by default. Customize these options to nil if you want -the previous behavior. - -** Xref - -+++ -*** When an *xref* buffer is needed, 'TAB' quits and jumps to an xref. - -A new command 'xref-quit-and-goto-xref', bound to 'TAB' in *xref* -buffers, quits the window before jumping to the destination. In many -situations, the intended window configuration is restored, just as if -the *xref* buffer hadn't been necessary in the first place. +*** New connection method "owncloud", which allows to access OwnCloud +or NextCloud hosted files and directories. -* New Modes and Packages in Emacs 26.1 - ---- -** New Elisp data-structure library 'radix-tree'. - ---- -** New library 'xdg' with utilities for some XDG standards and specs. - -** HTML +* New Modes and Packages in Emacs 27.1 +++ -*** A new submode of 'html-mode', 'mhtml-mode', is now the default -mode for *.html files. This mode handles indentation, -fontification, and commenting for embedded JavaScript and CSS. - ---- -** New mode 'conf-toml-mode' is a sub-mode of 'conf-mode', specialized -for editing TOML files. - ---- -** New mode 'conf-desktop-mode' is a sub-mode of 'conf-unix-mode', -specialized for editing freedesktop.org desktop entries. - ---- -** New minor mode 'pixel-scroll-mode' provides smooth pixel-level scrolling. - ---- -** New major mode 'less-css-mode' (a minor variant of 'css-mode') for -editing Less files. +** 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 chapter "(tramp) Archive file +names" in the Tramp manual for full documentation of these facilities. -* Incompatible Lisp Changes in Emacs 26.1 - ---- -** 'password-data' is now a hash-table so that 'password-read' can use -any object for the 'key' argument. - -+++ -** Command 'dired-mark-extension' now automatically prepends a '.' to the -extension when not present. The new command 'dired-mark-suffix' behaves -similarly but it doesn't prepend a '.'. - -+++ -** Certain cond/pcase/cl-case forms are now compiled using a faster jump -table implementation. This uses a new bytecode op 'switch', which -isn't compatible with previous Emacs versions. This functionality can -be disabled by setting 'byte-compile-cond-use-jump-table' to nil. - -+++ -** If 'comment-auto-fill-only-comments' is non-nil, 'auto-fill-function' -is now called only if either no comment syntax is defined for the -current buffer or the self-insertion takes place within a comment. - ---- -** The alist 'ucs-names' is now a hash table. - ---- -** 'if-let' and 'when-let' are subsumed by 'if-let*' and 'when-let*'. -The incumbent 'if-let' and 'when-let' are now marked obsolete. -'if-let*' and 'when-let*' do not accept the single tuple special case. -New macro 'and-let*' is an implementation of the Scheme SRFI-2 syntax -of the same name. 'if-let*' and 'when-let*' now accept the same -binding syntax as 'and-let*'. - ---- -** 'C-up', 'C-down', 'C-left' and 'C-right' are now defined in term -mode to send the same escape sequences that xterm does. This makes -things like 'forward-word' in readline work. - ---- -** Customizable variable 'query-replace-from-to-separator' -now doesn't propertize the string value of the separator. -Instead, text properties are added by 'query-replace-read-from'. -Additionally, the new nil value restores pre-24.5 behavior -of not providing replacement pairs via the history. - ---- -** Some obsolete functions, variables, and faces have been removed: - -*** 'make-variable-frame-local'. Variables cannot be frame-local any more. - -*** From subr.el: 'window-dot', 'set-window-dot', 'read-input', -'show-buffer', 'eval-current-buffer', 'string-to-int'. - -*** 'icomplete-prospects-length'. - -*** All the default-FOO variables that hold the default value of the -FOO variable. Use 'default-value' and 'setq-default' to access and -change FOO, respectively. The exhaustive list of removed variables is: -'default-mode-line-format', 'default-header-line-format', -'default-line-spacing', 'default-abbrev-mode', 'default-ctl-arrow', -'default-truncate-lines', 'default-left-margin', 'default-tab-width', -'default-case-fold-search', 'default-left-margin-width', -'default-right-margin-width', 'default-left-fringe-width', -'default-right-fringe-width', 'default-fringes-outside-margins', -'default-scroll-bar-width', 'default-vertical-scroll-bar', -'default-indicate-empty-lines', 'default-indicate-buffer-boundaries', -'default-fringe-indicator-alist', 'default-fringe-cursor-alist', -'default-scroll-up-aggressively', 'default-scroll-down-aggressively', -'default-fill-column', 'default-cursor-type', -'default-cursor-in-non-selected-windows', -'default-buffer-file-coding-system', 'default-major-mode', and -'default-enable-multibyte-characters'. - -*** Many variables obsoleted in 22.1 referring to face symbols. - -+++ -** The variable 'text-quoting-style' is now a customizable option. It -controls whether to and how to translate ASCII quotes in messages and -help output. Its possible values and their semantics remain unchanged -from Emacs 25. In particular, when this variable's value is 'grave', -all quotes in formats are output as-is. - ---- -** Functions like 'check-declare-file' and 'check-declare-directory' -now generate less chatter and more-compact diagnostics. The auxiliary -function 'check-declare-errmsg' has been removed. - -+++ -** The regular expression character class '[:blank:]' now matches -Unicode horizontal whitespace as defined in the Unicode Technical -Standard #18. If you only want to match space and tab, use '[ \t]' -instead. +* Incompatible Lisp Changes in Emacs 27.1 -+++ -** 'min' and 'max' no longer round their results. -Formerly, they returned a floating-point value if any argument was -floating-point, which was sometimes numerically incorrect. For -example, on a 64-bit host (max 1e16 10000000000000001) now returns its -second argument instead of its first. - -+++ -** The variable 'old-style-backquotes' has been made internal and -renamed to 'lread--old-style-backquotes'. No user code should use -this variable. - ---- -** To avoid confusion caused by "smart quotes", the reader no longer -accepts Lisp symbols which begin with the following quotation -characters: ‘’‛“”‟〞＂＇, unless they are escaped with backslash. - -+++ -** 'default-file-name-coding-system' now defaults to a coding system -that does not process CRLF. For example, it defaults to 'utf-8-unix' -instead of to 'utf-8'. Before this change, Emacs would sometimes -mishandle file names containing these control characters. - -+++ -** 'file-attributes', 'file-symlink-p' and 'make-symbolic-link' no -longer quietly mutate the target of a local symbolic link, so that -Emacs can access and copy them reliably regardless of their contents. -The following changes are involved. - ---- -*** 'file-attributes' and 'file-symlink-p' no longer prepend "/:" to -symbolic links whose targets begin with "/" and contain ":". For -example, if a symbolic link "x" has a target "/y:z:", '(file-symlink-p -"x")' now returns "/y:z:" rather than "/:/y:z:". - ---- -*** 'make-symbolic-link' no longer looks for file name handlers of -target when creating a symbolic link. For example, -'(make-symbolic-link "/y:z:" "x")' now creates a symbolic link to -"/y:z:" instead of failing. - -+++ -*** 'make-symbolic-link' removes the remote part of a link target if -target and newname have the same remote part. For example, -'(make-symbolic-link "/x:y:a" "/x:y:b")' creates a link with the -literal string "a"; and '(make-symbolic-link "/x:y:a" "/x:z:b")' -creates a link with the literal string "/x:y:a" instead of failing. - -+++ -*** 'make-symbolic-link' now expands a link target with leading "~" -only when the optional third arg is an integer, as when invoked -interactively. For example, '(make-symbolic-link "~y" "x")' now -creates a link with target the literal string "~y"; to get the old -behavior, use '(make-symbolic-link (expand-file-name "~y") "x")'. To -avoid this expansion in interactive use, you can now prefix the link -target with "/:". For example, '(make-symbolic-link "/:~y" "x" 1)' -now creates a link to literal "~y". - -+++ -** 'file-truename' returns a quoted file name if the target of a -symbolic link has remote file name syntax. - -+++ -** Module functions are now implemented slightly differently; in -particular, the function 'internal--module-call' has been removed. -Code that depends on undocumented internals of the module system might -break. - ---- -** The argument LOCKNAME of 'write-region' is propagated to file name -handlers now. - ---- -** When built against recent versions of GTK+, Emacs always uses -gtk_window_move for moving frames and ignores the value of the -variable 'x-gtk-use-window-move'. The variable is now obsolete. - -+++ -** Several functions that create or rename files now treat their -destination argument specially only when it is a directory name, i.e., -when it ends in '/' on GNU and other POSIX-like systems. When the -destination argument D of one of these functions is an existing -directory and the intent is to act on an entry in that directory, D -should now be a directory name. For example, (rename-file "e" "f/") -renames to 'f/e'. Although this formerly happened sometimes even when -D was not a directory name, as in (rename-file "e" "f") where 'f' -happened to be a directory, the old behavior often contradicted the -documentation and had inherent races that led to security holes. A -call like (rename-file C D) that used the old, undocumented behavior -can be written as (rename-file C (file-name-as-directory D)), a -formulation portable to both older and newer versions of Emacs. -Affected functions include 'add-name-to-file', 'copy-directory', -'copy-file', 'format-write-file', 'gnus-copy-file', -'make-symbolic-link', 'rename-file', 'thumbs-rename-images', and -'write-file'. - ---- -** The list returned by 'overlays-at' is now in decreasing priority order. -The documentation of this function always said the order should be -that of decreasing priority, if the 2nd argument of the function is -non-nil, but the code returned the list in the increasing order of -priority instead. Now the code does what the documentation says it -should do. - -+++ -** 'format' now avoids allocating a new string in more cases. -'format' was previously documented to return a newly-allocated string, -but this documentation was not correct, as (eq x (format x)) returned -t when x was the empty string. 'format' is no longer documented to -return a newly-allocated string, and the implementation now takes -advantage of the doc change to avoid making copies of strings in -common cases like (format "foo") and (format "%s" "foo"). +** The FILENAME argument to 'file-name-base' is now mandatory and no +longer defaults to 'buffer-file-name'. --- ** The function 'eldoc-message' now accepts a single argument. @@ -1478,601 +187,44 @@ them through 'format' first. Even that is discouraged: for ElDoc support, you should set 'eldoc-documentation-function' instead of calling 'eldoc-message' directly. ---- -** Using '&rest' or '&optional' incorrectly is now an error. -For example giving '&optional' without a following variable, or -passing '&optional' multiple times: - - (defun foo (&optional &rest x)) - (defun bar (&optional &optional x)) - -Previously, Emacs would just ignore the extra keyword, or give -incorrect results in certain cases. - ---- -** The pinentry.el library has been removed. -That package (and the corresponding change in GnuPG and pinentry) -was intended to provide a way to input passphrase through Emacs with -GnuPG 2.0. However, the change to support that was only implemented -in GnuPG >= 2.1 and didn't get backported to GnuPG 2.0. And with -GnuPG 2.1 and later, pinentry.el is not needed at all. So the -library was useless, and we removed it. GnuPG 2.0 is no longer -supported by the upstream project. - -To adapt to the change, you may need to set 'epa-pinentry-mode' to the -symbol 'loopback'. - -Note that previously, it was said that passphrase input through -minibuffer would be much less secure than other graphical pinentry -programs. However, these days the difference is insignificant: the -'read-password' function sufficiently protects input from leakage to -message logs. Emacs still doesn't use secure memory to protect -passphrases, but it was also removed from other pinentry programs as -the attack is unrealistic on modern computer systems which don't -utilize swap memory usually. +** 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. -* Lisp Changes in Emacs 26.1 - -+++ -** The function 'assoc' now takes an optional third argument TESTFN. -This argument, when non-nil, is used for comparison instead of -'equal'. - -+++ -** New optional argument TESTFN in 'alist-get', 'map-elt' and 'map-put'. -If non-nil, the argument specifies a function to use for comparison, -instead of, respectively, 'assq' and 'eql'. - -+++ -** New function 'seq-set-equal-p' to check if SEQUENCE1 and SEQUENCE2 -contain the same elements, regardless of the order. - -+++ -** The new function 'mapbacktrace' applies a function to all frames of -the current stack trace. - -+++ -** The new function 'file-name-case-insensitive-p' tests whether a -given file is on a case-insensitive filesystem. - -+++ -** Several accessors for the value returned by 'file-attributes' -have been added. They are: 'file-attribute-type', -'file-attribute-link-number', 'file-attribute-user-id', -'file-attribute-group-id', 'file-attribute-access-time', -'file-attribute-modification-time', -'file-attribute-status-change-time', 'file-attribute-size', -'file-attribute-modes', 'file-attribute-inode-number', -'file-attribute-device-number' and 'file-attribute-collect'. - -+++ -** The new function 'buffer-hash' computes a fast, non-consing hash of -a buffer's contents. - -+++ -** 'interrupt-process' now consults the list 'interrupt-process-functions', -to determine which function has to be called in order to deliver the -SIGINT signal. This allows Tramp to send the SIGINT signal to remote -asynchronous processes. The hitherto existing implementation has been -moved to 'internal-default-interrupt-process'. - -+++ -** The new function 'read-multiple-choice' prompts for multiple-choice -questions, with a handy way to display help texts. - ---- -** 'comment-indent-function' values may now return a cons to specify a -range of indentation. - -+++ -** New optional argument TEXT in 'make-temp-file'. - ---- -** New function 'define-symbol-prop'. - -+++ -** New function 'secure-hash-algorithms' to list the algorithms that -'secure-hash' supports. -See the node "(elisp) Checksum/Hash" in the ELisp manual for details. - -+++ -** Emacs now exposes the GnuTLS cryptographic API with the functions -'gnutls-macs' and 'gnutls-hash-mac'; 'gnutls-digests' and -'gnutls-hash-digest'; 'gnutls-ciphers' and 'gnutls-symmetric-encrypt' -and 'gnutls-symmetric-decrypt'. -See the node "(elisp) GnuTLS Cryptography" in the ELisp manual for details. - -+++ -** The function 'gnutls-available-p' now returns a list of capabilities -supported by the GnuTLS library used by Emacs. - -+++ -** Emacs now supports records for user-defined types, via the new -functions 'make-record', 'record', and 'recordp'. Records are now -used internally to represent cl-defstruct and defclass instances, for -example. - -If your program defines new record types, you should use -package-naming conventions for naming those types. This is so any -potential conflicts with other types are avoided. - -+++ -** 'save-some-buffers' now uses 'save-some-buffers-default-predicate' -to decide which buffers to ask about, if the PRED argument is nil. -The default value of 'save-some-buffers-default-predicate' is nil, -which means ask about all file-visiting buffers. - ---- -** string-(to|as|make)-(uni|multi)byte are now declared obsolete. - -+++ -** New variable 'while-no-input-ignore-events' which allow -setting which special events 'while-no-input' should ignore. -It is a list of symbols. +* Lisp Changes in Emacs 27.1 ---- -** New function 'undo-amalgamate-change-group' to get rid of -undo-boundaries between two states. - ---- -** New var 'definition-prefixes' is a hash table mapping prefixes to -the files where corresponding definitions can be found. This can be -used to fetch definitions that are not yet loaded, for example for -'C-h f'. - ---- -** New var 'syntax-ppss-table' to control the syntax-table used in -'syntax-ppss'. - -+++ -** 'define-derived-mode' can now specify an :after-hook form, which -gets evaluated after the new mode's hook has run. This can be used to -incorporate configuration changes made in the mode hook into the -mode's setup. - ---- -** Autoload files can be generated without timestamps, -by setting 'autoload-timestamps' to nil. -FIXME As an experiment, nil is the current default. -If no insurmountable problems before next release, it can stay that way. - ---- -** 'gnutls-boot' now takes a parameter ':complete-negotiation' that -says that negotiation should complete even on non-blocking sockets. - ---- -** There is now a new variable 'flyspell-sort-corrections-function' -that allows changing the way corrections are sorted. - ---- -** The new command 'fortune-message' has been added, which displays -fortunes in the echo area. - -+++ -** New function 'func-arity' returns information about the argument list -of an arbitrary function. This generalizes 'subr-arity' for functions -that are not built-in primitives. We recommend using this new -function instead of 'subr-arity'. - ---- -** New function 'region-bounds' can be used in the interactive spec -to provide region boundaries (for rectangular regions more than one) -to an interactively callable function as a single argument instead of -two separate arguments 'region-beginning' and 'region-end'. - -+++ -** 'parse-partial-sexp' state has a new element. Element 10 is -non-nil when the last character scanned might be the first character -of a two character construct, i.e., a comment delimiter or escaped -character. Its value is the syntax of that last character. - -+++ -** 'parse-partial-sexp's state, element 9, has now been confirmed as -permanent and documented, and may be used by Lisp programs. Its value -is a list of currently open parenthesis positions, starting with the -outermost parenthesis. +** 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. --- -** 'read-color' will now display the color names using the color itself -as the background color. +** 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 (Bug#28639). --- -** The function 'redirect-debugging-output' now works on platforms -other than GNU/Linux. - -+++ -** The new function 'string-version-lessp' compares strings by -interpreting consecutive runs of numerical characters as numbers, and -compares their numerical values. According to this predicate, -"foo2.png" is smaller than "foo12.png". - ---- -** Numeric comparisons and 'logb' no longer return incorrect answers -due to internal rounding errors. For example, '(< most-positive-fixnum -(+ 1.0 most-positive-fixnum))' now correctly returns t on 64-bit hosts. - ---- -** The functions 'ffloor', 'fceiling', 'ftruncate' and 'fround' now -accept only floating-point arguments, as per their documentation. -Formerly, they quietly accepted integer arguments and sometimes -returned nonsensical answers, e.g., '(< N (ffloor N))' could return t. - ---- -** On hosts like GNU/Linux x86-64 where a 'long double' fraction -contains at least EMACS_INT_WIDTH - 3 bits, 'format' no longer returns -incorrect answers due to internal rounding errors when formatting -Emacs integers with '%e', '%f', or '%g' conversions. For example, on -these hosts '(eql N (string-to-number (format "%.0f" N)))' now returns -t for all Emacs integers N. - ---- -** Calls that accept floating-point integers (for use on hosts with -limited integer range) now signal an error if arguments are not -integral. For example '(decode-char 'ascii 0.5)' now signals an error. - -+++ -** The new function 'char-from-name' converts a Unicode name string -to the corresponding character code. - -+++ -** New functions 'sxhash-eq' and 'sxhash-eql' return hash codes of a -Lisp object suitable for use with 'eq' and 'eql' correspondingly. If -two objects are 'eq' ('eql'), then the result of 'sxhash-eq' -('sxhash-eql') on them will be the same. - -+++ -** Function 'sxhash' has been renamed to 'sxhash-equal' for -consistency with the new functions. For compatibility, 'sxhash' -remains as an alias to 'sxhash-equal'. - -+++ -** 'make-hash-table' now defaults to a rehash threshold of 0.8125 -instead of 0.8, to avoid rounding glitches. - -+++ -** New function 'add-variable-watcher' can be used to call a function -when a symbol's value is changed. This is used to implement the new -debugger command 'debug-on-variable-change'. - -+++ -** Time conversion functions that accept a time zone rule argument now -allow it to be OFFSET or a list (OFFSET ABBR), where the integer -OFFSET is a count of seconds east of Universal Time, and the string -ABBR is a time zone abbreviation. The affected functions are -'current-time-string', 'current-time-zone', 'decode-time', -'format-time-string', and 'set-time-zone-rule'. - -+++ -** 'format-time-string' now formats '%q' to the calendar quarter. - -+++ -** New built-in function 'mapcan'. -It avoids unnecessary consing (and garbage collection). - -+++ -** 'car' and 'cdr' compositions 'cXXXr' and 'cXXXXr' are now part of Elisp. - -+++ -** 'gensym' is now part of Elisp. - ---- -** Low-level list functions like 'length' and 'member' now do a better -job of signaling list cycles instead of looping indefinitely. - -+++ -** The new functions 'make-nearby-temp-file' and 'temporary-file-directory' -can be used for creation of temporary files on remote or mounted directories. - -+++ -** On GNU platforms when operating on a local file, 'file-attributes' -no longer suffers from a race when called while another process is -altering the filesystem. On non-GNU platforms 'file-attributes' -attempts to detect the race, and returns nil if it does so. - -+++ -** The new function 'file-local-name' can be used to specify arguments -of remote processes. - -+++ -** The new functions 'file-name-quote', 'file-name-unquote' and -'file-name-quoted-p' can be used to quote / unquote file names with -the prefix "/:". - -+++ -** The new error 'file-missing', a subcategory of 'file-error', is now -signaled instead of 'file-error' if a file operation acts on a file -that does not exist. - -+++ -** The function 'delete-directory' no longer signals an error when -operating recursively and when some other process deletes the directory -or its files before 'delete-directory' gets to them. - -+++ -** New error type 'user-search-failed' like 'search-failed' but -avoids debugger like 'user-error'. - -+++ -** The function 'line-number-at-pos' now takes a second optional -argument 'absolute'. If this parameter is nil, the default, this -function keeps on returning the line number taking potential narrowing -into account. If this parameter is non-nil, the function ignores -narrowing and returns the absolute line number. - ---- -** The function 'color-distance' now takes a second optional argument -'metric'. When non-nil, it should be a function of two arguments that -accepts two colors and returns a number. - -** Changes in Frame and Window Handling - -+++ -*** Resizing a frame no longer runs 'window-configuration-change-hook'. -'window-size-change-functions' should be used instead. - -+++ -*** The new function 'frame-size-changed-p' can tell whether a frame has -been resized since the last time 'window-size-change-functions' has been -run. - -+++ -*** The function 'frame-geometry' now also returns the width of a -frame's outer border. - -+++ -*** New frame parameters and changed semantics for older ones: - -+++ -**** 'z-group' positions a frame above or below all others. - -+++ -**** 'min-width' and 'min-height' specify the absolute minimum size of a -frame. - -+++ -**** 'parent-frame' makes a frame the child frame of another Emacs -frame. The section "(elisp) Child Frames" in the ELisp manual -describes the intrinsics of that relationship. - -+++ -**** 'delete-before' triggers deletion of one frame before that of -another. - -+++ -**** 'mouse-wheel-frame' specifies another frame whose windows shall be -scrolled instead. - -+++ -**** 'no-other-frame' has 'next-frame' and 'previous-frame' skip this -frame. - -+++ -**** 'skip-taskbar' removes a frame's icon from the taskbar and has -'Alt-<TAB>' skip this frame. - -+++ -**** 'no-focus-on-map' avoids that a frame gets input focus when mapped. - -+++ -**** 'no-accept-focus' means that a frame does not want to get input -focus via the mouse. - -+++ -**** 'undecorated' removes the window manager decorations from a frame. - -+++ -**** 'override-redirect' tells the window manager to disregard this -frame. - -+++ -**** 'width' and 'height' allow to specify pixel values and ratios now. - -+++ -**** 'left' and 'top' allow to specify ratios now. - -+++ -**** 'keep-ratio' preserves size and position of child frames when their -parent frame is resized. - -+++ -**** 'no-special-glyphs' suppresses display of truncation and -continuation glyphs in a frame. +** The function 'get-free-disk-space' returns now a non-nil value for +remote systems, which support this check. +++ -**** 'auto-hide-function' and 'minibuffer-exit' handle auto hiding of -frames and exiting from minibuffer individually. +** 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. -+++ -**** 'fit-frame-to-buffer-margins' and 'fit-frame-to-buffer-sizes' -handle fitting a frame to its buffer individually. - -+++ -**** 'drag-internal-border', 'drag-with-header-line', -'drag-with-mode-line', 'snap-width', 'top-visible' and 'bottom-visible' -allow to drag and resize frames with the mouse. - -+++ -**** 'minibuffer' is now set to the default minibuffer window when -initially specified as nil and is not reset to nil when initially -specifying a minibuffer window. - -*** The new function 'frame-list-z-order' returns a list of all frames -in Z (stacking) order. - -+++ -*** The function 'x-focus-frame' optionally tries to not activate its -frame. - -+++ -*** The variable 'focus-follows-mouse' has a third meaningful value -'auto-raise' to indicate that the window manager automatically raises a -frame when the mouse pointer enters it. - -+++ -*** The new function 'frame-restack' puts a frame above or below -another on the display. - -+++ -*** The new face 'internal-border' specifies the background of a frame's -internal border. - -+++ -*** The NORECORD argument of 'select-window' now has a meaningful value -'mark-for-redisplay' which is like any other non-nil value but marks -WINDOW for redisplay. - -+++ -*** Support for side windows is now official. The display action -function 'display-buffer-in-side-window' will display its buffer in a -side window. Functions for toggling all side windows on a frame, -changing and reversing the layout of side windows and returning the -main (major non-side) window of a frame are provided. For details -consult the section "(elisp) Side Windows" in the ELisp manual. - -+++ -*** Support for atomic windows - rectangular compositions of windows -treated by 'split-window', 'delete-window' and 'delete-other-windows' -like a single live window - is now official. For details consult the -section "(elisp) Atomic Windows" in the ELisp manual. - -+++ -*** New 'display-buffer' alist entry 'window-parameters' allows to -assign window parameters to the window used for displaying the buffer. - -+++ -*** New function 'display-buffer-reuse-mode-window' is an action function -suitable for use in 'display-buffer-alist'. For example, to avoid -creating a new window when opening man pages when there's already one, -use - -(add-to-list 'display-buffer-alist - '("\\`\\*Man .*\\*\\'" . - (display-buffer-reuse-mode-window - (inhibit-same-window . nil) - (mode . Man-mode)))) - -+++ -*** New window parameter 'no-delete-other-windows' prevents that -its window gets deleted by 'delete-other-windows'. - -+++ -*** New window parameters 'mode-line-format' and 'header-line-format' -allow to override the buffer-local formats for this window. - -+++ -*** New command 'window-swap-states' swaps the states of two live -windows. - -+++ -*** New functions 'window-pixel-width-before-size-change' and -'window-pixel-height-before-size-change' support detecting which -window changed size when 'window-size-change-functions' are run. - -+++ -*** The new function 'window-lines-pixel-dimensions' returns the pixel -dimensions of a window's text lines. - -+++ -*** The new function 'window-largest-empty-rectangle' returns the -dimensions of the largest rectangular area not occupying any text in a -window's body. - -+++ -*** The semantics of 'mouse-autoselect-window' has changed slightly. -For details see the section "(elisp) Mouse Window Auto-selection" in -the ELisp manual. - ---- -*** 'select-frame-by-name' now may return a frame on another display -if it does not find a suitable one on the current display. - ---- -** 'tcl-auto-fill-mode' is now declared obsolete. Its functionality -can be replicated simply by setting 'comment-auto-fill-only-comments'. - -** New pcase pattern 'rx' to match against an rx-style regular expression. -For details, see the doc string of 'rx--pcase-macroexpander'. +** 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 functions to set region from secondary selection and vice versa. -The new functions 'secondary-selection-to-region' and -'secondary-selection-from-region' let you set the beginning and the -end of the region from those of the secondary selection and vice -versa. - -** New function 'lgstring-remove-glyph' can be used to modify a -gstring returned by the underlying layout engine (e.g. m17n-flt, -uniscribe). +** 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. -* Changes in Emacs 26.1 on Non-Free Operating Systems - -+++ -** Intercepting hotkeys on Windows 7 and later now works better. -The new keyboard hooking code properly grabs system hotkeys such as -'Win-*' and 'Alt-TAB', in a way that Emacs can get at them before the -system. This makes the 'w32-register-hot-key' functionality work -again on all versions of MS-Windows starting with Windows 7. On -Windows NT and later you can now register any hotkey combination. (On -Windows 9X, the previous limitations, spelled out in the Emacs manual, -still apply.) - ---- -** 'convert-standard-filename' no longer mirrors slashes on MS-Windows. -Previously, on MS-Windows this function converted slash characters in -file names into backslashes. It no longer does that. If your Lisp -program used 'convert-standard-filename' to prepare file names to be -passed to subprocesses (which is not the recommended usage of that -function), you will now have to mirror slashes in your application -code. One possible way is this: - - (let ((start 0)) - (while (string-match "/" file-name start) - (aset file-name (match-beginning 0) ?\\) - (setq start (match-end 0)))) - ---- -** GUI sessions on MS-Windows now treat SIGINT like Posix platforms do. -The effect of delivering a Ctrl-C (SIGINT) signal to a GUI Emacs on -MS-Windows is now the same as on Posix platforms -- Emacs saves the -session and exits. In particular, this will happen if you start -emacs.exe from the Windows shell, then type Ctrl-C into that shell's -window. - ---- -** 'signal-process' supports SIGTRAP on Windows XP and later. -The 'kill' emulation on Windows now maps SIGTRAP to a call to the -'DebugBreakProcess' API. This causes the receiving process to break -execution and return control to the debugger. If no debugger is -attached to the receiving process, the call is typically ignored. -This is in contrast to the default action on POSIX Systems, where it -causes the receiving process to terminate with a core dump if no -debugger has been attached to it. - ---- -** 'set-mouse-position' and 'set-mouse-absolute-pixel-position' work -on macOS. - ---- -** Emacs can now be run as a GUI application from the command line on -macOS. - -+++ -** 'ns-appearance' and 'ns-transparent-titlebar' change the appearance -of frame decorations on macOS 10.9+. - ---- -** 'ns-use-thin-smoothing' enables thin font smoothing on macOS 10.8+. - ---- -** 'process-attributes' on Darwin systems now returns more information. - ---- -** Mousewheel and trackpad scrolling on macOS 10.7+ now behaves more -like the macOS default. The new variables 'ns-mwheel-line-height', -'ns-use-mwheel-acceleration' and 'ns-use-mwheel-momentum' can be used -to customize the behavior. +* Changes in Emacs 27.1 on Non-Free Operating Systems ---------------------------------------------------------------------- diff --git a/etc/NEWS.26 b/etc/NEWS.26 new file mode 100644 index 00000000000..55385f59a80 --- /dev/null +++ b/etc/NEWS.26 @@ -0,0 +1,2099 @@ +GNU Emacs NEWS -- history of user-visible changes. + +Copyright (C) 2016-2018 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 26. + +See file HISTORY for a list of GNU Emacs versions and release dates. +See files NEWS.25, NEWS.24, ..., 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 necessary documentation updates have been done. + (This means all the relevant manuals in doc/ AND lisp doc-strings.) +--- means doc strings are updated, and no change in the manuals is needed. +When you add a new item, use the appropriate mark if you are sure it applies, + + +* Installation Changes in Emacs 26.1 + +--- +** By default libgnutls is now required when building Emacs. +Use 'configure --with-gnutls=no' to build even when GnuTLS is missing. + +--- +** GnuTLS version 2.12.2 or later is now required, instead of merely +version 2.6.6 or later. + ++++ +** The new option 'configure --with-mailutils' causes Emacs to rely on +GNU Mailutils to retrieve email. It is recommended, and is the +default if GNU Mailutils is installed. When --with-mailutils is not +in effect, the Emacs build procedure by default continues to build and +install a limited 'movemail' substitute that retrieves POP3 email only +via insecure channels. To avoid this problem, use either +--with-mailutils or --without-pop when configuring; --without-pop +is the default on platforms other than native MS-Windows. + +--- +** The new option 'configure --enable-gcc-warnings=warn-only' causes +GCC to issue warnings without stopping the build. This behavior is +now the default in developer builds. As before, use +'--disable-gcc-warnings' to suppress GCC's warnings, and +'--enable-gcc-warnings' to stop the build if GCC issues warnings. + +--- +** When GCC warnings are enabled, '--enable-check-lisp-object-type' is +now enabled by default when configuring. + ++++ +** The Emacs server now has socket-launching support. This allows +socket based activation, where an external process like systemd can +invoke the Emacs server process upon a socket connection event and +hand the socket over to Emacs. Emacs uses this socket to service +emacsclient commands. This new functionality can be disabled with the +configure option '--disable-libsystemd'. + ++++ +** A systemd user unit file is provided. Use it in the standard way: +'systemctl --user enable emacs'. +(If your Emacs is installed in a non-standard location, you may +need to copy the emacs.service file to eg ~/.config/systemd/user/) + +--- +** New configure option '--disable-build-details' attempts to build an +Emacs that is more likely to be reproducible; that is, if you build +and install Emacs twice, the second Emacs is a copy of the first. +Deterministic builds omit the build date from the output of the +'emacs-version' and 'erc-cmd-SV' functions, and the leave the +following variables nil: 'emacs-build-system', 'emacs-build-time', +'erc-emacs-build-time'. + +--- +** Emacs can now be built with support for Little CMS. + +If the lcms2 library is installed, Emacs will enable features built on +top of that library. The new configure option '--without-lcms2' can +be used to build without lcms2 support even if it is installed. Emacs +linked to Little CMS exposes color management functions in Lisp: the +color metrics 'lcms-cie-de2000' and 'lcms-cam02-ucs', as well as +functions for conversion to and from CIE CAM02 and CAM02-UCS. + +--- +** The configure option '--with-gameuser' now defaults to 'no', +as this appears to be the most common configuration in practice. +When it is 'no', the shared game directory and the auxiliary program +update-game-score are no longer needed and are not installed. + +--- +** Emacs no longer works on IRIX. We expect that Emacs users are not +affected by this, as SGI stopped supporting IRIX in December 2013. + + +* Startup Changes in Emacs 26.1 + ++++ +** New option '--fg-daemon'. This is the same as '--daemon', except +it runs in the foreground and does not fork. This is intended for +modern init systems such as systemd, which manage many of the traditional +aspects of daemon behavior themselves. '--bg-daemon' is now an alias +for '--daemon'. + ++++ +** New option '--module-assertions'. +When given this option, Emacs will perform expensive correctness +checks when dealing with dynamic modules. This is intended for module +authors that wish to verify that their module conforms to the module +requirements. The option makes Emacs abort if a module-related +assertion triggers. + ++++ +** Emacs now supports 24-bit colors on capable text terminals. +Terminal is automatically initialized to use 24-bit colors if the +required capabilities are found in terminfo. See the FAQ node +"(efaq) Colors on a TTY" for more information. + ++++ +** Emacs now obeys the X resource "scrollBar" at startup. +The effect is similar to that of "toolBar" resource on the tool bar. + + +* Changes in Emacs 26.1 + ++++ +** Option 'buffer-offer-save' can be set to new value, 'always'. When +set to 'always', the command 'save-some-buffers' will always offer +this buffer for saving. + +** Security vulnerability related to Enriched Text mode is removed. + ++++ +*** Enriched Text mode does not evaluate Lisp in 'display' properties. +This feature allows saving 'display' properties as part of text. +Emacs 'display' properties support evaluation of arbitrary Lisp forms +as part of processing the property for display, so displaying Enriched +Text could be vulnerable to executing arbitrary malicious Lisp code +included in the text (e.g., sent as part of an email message). +Therefore, execution of arbitrary Lisp forms in 'display' properties +decoded by Enriched Text mode is now disabled by default. Customize +the new option 'enriched-allow-eval-in-display-props' to a non-nil +value to allow Lisp evaluation in decoded 'display' properties. + +This vulnerability was introduced in Emacs 21.1. To work around that +in Emacs versions before 25.3, append the following to your ~/.emacs +init file: + + (eval-after-load "enriched" + '(defun enriched-decode-display-prop (start end &optional param) + (list start end))) + ++++ +** Functions in 'write-contents-functions' can fully short-circuit the +'save-buffer' process. Previously, saving a buffer that was not +visiting a file would always prompt for a file name. Now it only does +so if 'write-contents-functions' is nil (or all its functions return +nil). + +--- +** New variable 'executable-prefix-env' for inserting magic signatures. +This variable affects the format of the interpreter magic number +inserted by 'executable-set-magic'. If non-nil, the magic number now +takes the form "#!/usr/bin/env interpreter", otherwise the value +determined by 'executable-prefix', which is by default +"#!/path/to/interpreter". By default, 'executable-prefix-env' is nil, +so the default behavior is not changed. + ++++ +** The variable 'emacs-version' no longer includes the build number. +This is now stored separately in a new variable, 'emacs-build-number'. + ++++ +** Emacs now provides a limited form of concurrency with Lisp threads. +Concurrency in Emacs Lisp is "mostly cooperative", meaning that +Emacs will only switch execution between threads at well-defined +times: when Emacs waits for input, during blocking operations related +to threads (such as mutex locking), or when the current thread +explicitly yields. Global variables are shared among all threads, but +a 'let' binding is thread-local. Each thread also has its own current +buffer and its own match data. + +See the chapter "(elisp) Threads" in the ELisp manual for full +documentation of these facilities. + ++++ +** The new user variable 'electric-quote-chars' provides a list +of curved quotes for 'electric-quote-mode', allowing user to choose +the types of quotes to be used. + +--- +** The new user option 'electric-quote-context-sensitive' makes +'electric-quote-mode' context sensitive. If it is non-nil, you can +type an ASCII apostrophe to insert an opening or closing quote, +depending on context. Emacs will replace the apostrophe by an opening +quote character at the beginning of the buffer, the beginning of a +line, after a whitespace character, and after an opening parenthesis; +and it will replace the apostrophe by a closing quote character in all +other cases. + +--- +** The new variable 'electric-quote-inhibit-functions' controls when +to disable electric quoting based on context. Major modes can add +functions to this list; Emacs will temporarily disable +'electric-quote-mode' whenever any of the functions returns non-nil. +This can be used by major modes that derive from 'text-mode' but allow +inline code segments, such as 'markdown-mode'. + ++++ +** The new user variable 'dired-omit-case-fold' allows the user to +customize the case-sensitivity of dired-omit-mode. It defaults to +the same sensitivity as that of the filesystem for the corresponding +dired buffer. + ++++ +** Emacs now uses double buffering to reduce flicker when editing and +resizing graphical Emacs frames on the X Window System. This support +requires the DOUBLE-BUFFER extension, which major X servers have +supported for many years. If your system has this extension, but an +Emacs built with double buffering misbehaves on some displays you use, +you can disable the feature by adding + + '(inhibit-double-buffering . t) + +to default-frame-alist. Or inject this parameter into the selected +frame by evaluating this form: + + (modify-frame-parameters nil '((inhibit-double-buffering . t))) + +--- +** The customization group 'wp', whose label was "text", is now +deprecated. Use the new group 'text', which inherits from 'wp', +instead. + ++++ +** The new function 'call-shell-region' executes a command in an +inferior shell with the buffer region as input. + ++++ +** The new user option 'shell-command-dont-erase-buffer' controls +if the output buffer is erased between shell commands; if non-nil, +the output buffer is not erased; this variable also controls where +to set the point in the output buffer: beginning of the output, +end of the buffer or save the point. +When 'shell-command-dont-erase-buffer' is nil, the default value, +the behavior of 'shell-command', 'shell-command-on-region' and +'async-shell-command' is as usual. + ++++ +** The new user option 'async-shell-command-display-buffer' controls +whether the output buffer of an asynchronous command is shown +immediately, or only when there is output. + ++++ +** New user option 'mouse-select-region-move-to-beginning'. +This option controls the position of point when double-clicking +mouse-1 on the end of a parenthetical grouping or string-delimiter: +the default value nil keeps point at the end of the region, setting it +to non-nil moves point to the beginning of the region. + ++++ +** New user option 'mouse-drag-and-drop-region'. +This option allows to drag the entire region of text to another place +or another buffer. Its behavior is customizable via the new options +'mouse-drag-and-drop-region-cut-when-buffers-differ', +'mouse-drag-and-drop-region-show-tooltip', and +'mouse-drag-and-drop-region-show-cursor'. + ++++ +** The new user option 'confirm-kill-processes' allows the user to +skip a confirmation prompt for killing subprocesses when exiting +Emacs. When set to t (the default), Emacs will prompt for +confirmation before killing subprocesses on exit, which is the same +behavior as before. + +--- +** 'find-library-name' will now fall back on looking at 'load-history' +to try to locate libraries that have been loaded with an explicit path +outside 'load-path'. + ++++ +** Faces in 'minibuffer-prompt-properties' no longer overwrite properties +in the text in functions like 'read-from-minibuffer', but instead are +added to the end of the face list. This allows users to say things +like '(read-from-minibuffer (propertize "Enter something: " 'face 'bold))'. + ++++ +** The new variable 'extended-command-suggest-shorter' has been added +to control whether to suggest shorter 'M-x' commands or not. + +--- +** icomplete now respects 'completion-ignored-extensions'. + ++++ +** Non-breaking hyphens are now displayed with the 'nobreak-hyphen' +face instead of the 'escape-glyph' face. + ++++ +** Approximations to quotes are now displayed with the new 'homoglyph' +face instead of the 'escape-glyph' face. + ++++ +** New face 'header-line-highlight'. +This face is the header-line analogue of 'mode-line-highlight'; it +should be the preferred mouse-face for mouse-sensitive elements in the +header line. + +--- +** 'C-x h' ('mark-whole-buffer') will now avoid marking the prompt +part of minibuffers. + +--- +** 'fill-paragraph' no longer marks the buffer as changed unless it +actually changed something. + +--- +** The locale language name 'ca' is now mapped to the language +environment 'Catalan', which has been added. + +--- +** 'align-regexp' has a separate history for its interactive argument. +'align-regexp' no longer shares its history with all other +history-less functions that use 'read-string'. + ++++ +** The networking code has been reworked so that it's more +asynchronous than it was (when specifying :nowait t in +'make-network-process'). How asynchronous it is varies based on the +capabilities of the system, but on a typical GNU/Linux system the DNS +resolution, the connection, and (for TLS streams) the TLS negotiation +are all done without blocking the main Emacs thread. To get +asynchronous TLS, the TLS boot parameters have to be passed in (see +the manual for details). + +Certain process oriented functions (like 'process-datagram-address') +will block until socket setup has been performed. The recommended way +to deal with asynchronous sockets is to avoid interacting with them +until they have changed status to "run". This is most easily done +from a process sentinel. + +--- +** 'make-network-process' and 'open-network-stream' sometimes allowed +:service to be an integer string (e.g., :service "993") and sometimes +required an integer (e.g., :service 993). This difference has been +eliminated, and integer strings work everywhere. + +--- +** It is possible to disable attempted recovery on fatal signals. +Two new variables support disabling attempts to recover from stack +overflow and to avoid automatic auto-save when Emacs is delivered a +fatal signal. 'attempt-stack-overflow-recovery', if set to nil, +will disable attempts to recover from C stack overflows; Emacs will +then crash as with any other fatal signal. +'attempt-orderly-shutdown-on-fatal-signal', if set to nil, will +disable attempts to auto-save the session and shut down in an orderly +fashion when Emacs receives a fatal signal; instead, Emacs will +terminate immediately. Both variables are non-nil by default. +These variables are for users who would like to avoid the small +probability of data corruption due to techniques Emacs uses to recover +in these situations. + ++++ +** File local and directory local variables are now initialized each +time the major mode is set, not just when the file is first visited. +These local variables will thus not vanish on setting a major mode. + ++++ +** A second dir-local file (.dir-locals-2.el) is now accepted. +See the doc string of 'dir-locals-file' for more information. + ++++ +** Connection-local variables can be used to specify local variables +with a value depending on the connected remote server. For details, +see the node "(elisp) Connection Local Variables" in the ELisp manual. + +--- +** International domain names (IDNA) are now encoded via the new +puny.el library, so that one can visit Web sites with non-ASCII URLs. + ++++ +** The new 'list-timers' command lists all active timers in a buffer, +where you can cancel them with the 'c' command. + ++++ +** 'switch-to-buffer-preserve-window-point' now defaults to t. +Applications that call 'switch-to-buffer' and want to show the buffer at +the position of its point should use 'pop-to-buffer-same-window' in lieu +of 'switch-to-buffer'. + ++++ +** The new variable 'debugger-stack-frame-as-list' allows displaying +all call stack frames in a Lisp backtrace buffer as lists. Both +debug.el and edebug.el have been updated to heed to this variable. + +--- +** Values in call stack frames are now displayed using 'cl-prin1'. +The old behavior of using 'prin1' can be restored by customizing the +new option 'debugger-print-function'. + ++++ +** NUL bytes in text copied to the system clipboard are now replaced with "\0". + ++++ +** The new variable 'x-ctrl-keysym' has been added to the existing +roster of X keysyms. It can be used in combination with another +variable of this kind to swap modifiers in Emacs. + +--- +** New input methods: 'cyrillic-tuvan', 'polish-prefix', 'uzbek-cyrillic'. + +--- +** The 'dutch' input method no longer attempts to support Turkish too. +Also, it no longer converts 'IJ' and 'ij' to the compatibility +characters U+0132 LATIN CAPITAL LIGATURE IJ and U+0133 LATIN SMALL +LIGATURE IJ. + ++++ +** File name quoting by adding the prefix "/:" is now possible for the +local part of a remote file name. Thus, if you have a directory named +"/~" on the remote host "foo", you can prevent it from being +substituted by a home directory by writing it as "/foo:/:/~/file". + ++++ +** The new variable 'maximum-scroll-margin' allows having effective +settings of 'scroll-margin' up to half the window size, instead of +always restricting the margin to a quarter of the window. + ++++ +** Emacs can scroll horizontally using mouse, touchpad, and trackbar. +You can enable this by customizing 'mwheel-tilt-scroll-p'. If you +want to reverse the direction of the scroll, customize +'mwheel-flip-direction'. + ++++ +** The default GnuTLS priority string now includes %DUMBFW. +This is to avoid bad behavior in some firewalls, which causes the +connection to be closed by the remote host. + +** Emacsclient changes + ++++ +*** Emacsclient has a new option '-u' / '--suppress-output'. +This option suppresses display of return values from the server +process. + ++++ +*** Emacsclient has a new option '-T' / '--tramp'. +This helps with using a local Emacs session as the server for a remote +emacsclient. With appropriate setup, one can now set the EDITOR +environment variable on a remote machine to emacsclient, and +use the local Emacs to edit remote files via Tramp. See the node +"(emacs) emacsclient Options" in the user manual for the details. + ++++ +*** Emacsclient now accepts command-line options in ALTERNATE_EDITOR +and '--alternate-editor'. For example, ALTERNATE_EDITOR="emacs -Q -nw". +Arguments may be quoted "like this", so that for example an absolute +path containing a space may be specified; quote escaping is not +supported. + +--- +** New user option 'dig-program-options' and extended functionality +for DNS-querying functions 'nslookup-host', 'dns-lookup-host', +and 'run-dig'. Each function now accepts an optional name server +argument interactively (with a prefix argument) and non-interactively. + ++++ +** 'describe-key-briefly' now ignores mouse movement events. + ++++ +** The new variable 'eval-expression-print-maximum-character' prevents +large integers from being displayed as characters by 'M-:' and similar +commands. + +--- +** Two new commands for finding the source code of Emacs Lisp +libraries: 'find-library-other-window' and 'find-library-other-frame'. + ++++ +** The new variable 'display-raw-bytes-as-hex' allows to change the +display of raw bytes from octal to hex. + ++++ +** You can now provide explicit field numbers in format specifiers. +For example, '(format "%2$s %1$s %2$s" "X" "Y")' produces "Y X Y". + ++++ +** Emacs now supports optional display of line numbers in the buffer. +This is similar to what 'linum-mode' provides, but much faster and +doesn't usurp the display margin for the line numbers. Customize the +buffer-local variable 'display-line-numbers' to activate this optional +display. Alternatively, you can use the 'display-line-numbers-mode' +minor mode or the global 'global-display-line-numbers-mode'. When +using these modes, customize 'display-line-numbers-type' with the same +value as you would use with 'display-line-numbers'. + +Line numbers are not displayed at all in minibuffer windows and in +tooltips, as they are not useful there. + +Lisp programs can disable line-number display for a particular screen +line by putting the 'display-line-numbers-disable' text property or +overlay property on the first character of that screen line. This is +intended for add-on packages that need a finer control of the display. + +Lisp programs that need to know how much screen estate is used up for +line-number display in a window can use the new function +'line-number-display-width'. + +'linum-mode' and all similar packages are henceforth becoming obsolete. +Users and developers are encouraged to switch to this new feature +instead. + +--- +** The new user option 'arabic-shaper-ZWNJ-handling' controls how to +handle ZWNJ in Arabic text rendering. + + +* Editing Changes in Emacs 26.1 + ++++ +** New variable 'column-number-indicator-zero-based'. +Traditionally, in Column Number mode, the displayed column number +counts from zero starting at the left margin of the window. This +behavior is now controlled by 'column-number-indicator-zero-based'. +If you would prefer for the displayed column number to count from one, +you may set this variable to nil. (Behind the scenes, there is now a +new mode line construct, '%C', which operates exactly as '%c' does +except that it counts from one.) + ++++ +** New single-line horizontal scrolling mode. +The 'auto-hscroll-mode' variable can now have a new special value, +'current-line', which causes only the line where the cursor is +displayed to be horizontally scrolled when lines are truncated on +display and point moves outside the left or right window margin. + ++++ +** New mode line constructs '%o' and '%q', and user option +'mode-line-percent-position'. '%o' displays the "degree of travel" of +the window through the buffer. Unlike the default '%p', this +percentage approaches 100% as the window approaches the end of the +buffer. '%q' displays the percentage offsets of both the start and +the end of the window, e.g. "5-17%". The new option +'mode-line-percent-position' makes it easier to switch between '%p', +'%P', and these new constructs. + ++++ +** Two new user options 'list-matching-lines-jump-to-current-line' and +'list-matching-lines-current-line-face' to show the current line +highlighted in *Occur* buffer. + ++++ +** The 'occur' command can now operate on the region. + ++++ +** New bindings for 'query-replace-map'. +'undo', undo the last replacement; bound to 'u'. +'undo-all', undo all replacements; bound to 'U'. + +--- +** 'delete-trailing-whitespace' deletes whitespace after form feed. +In modes where form feed was treated as a whitespace character, +'delete-trailing-whitespace' would keep lines containing it unchanged. +It now deletes whitespace after the last form feed thus behaving the +same as in modes where the character is not whitespace. + +--- +** Emacs no longer prompts about editing a changed file when the file's +content is unchanged. Instead of only checking the modification time, +Emacs now also checks the file's actual content before prompting the user. + +--- +** Various casing improvements. + +*** 'upcase', 'upcase-region' et al. convert title case characters +(such as Dz) into their upper case form (such as DZ). + +*** 'capitalize', 'upcase-initials' et al. make use of title-case forms +of initial characters (correctly producing for example Džungla instead +of incorrect DŽungla). + +*** Characters which turn into multiple ones when cased are correctly handled. +For example, fi ligature is converted to FI when upper cased. + +*** Greek small sigma is correctly handled when at the end of the word. +Strings such as ΌΣΟΣ are now correctly converted to Όσος when +capitalized instead of incorrect Όσοσ (compare lowercase sigma at the +end of the word). + ++++ +** Emacs can now auto-save buffers to visited files in a more robust +manner via the new mode 'auto-save-visited-mode'. Unlike +'auto-save-visited-file-name', this mode uses the normal saving +procedure and therefore obeys saving hooks. +'auto-save-visited-file-name' is now obsolete. + ++++ +** New behavior of 'mark-defun'. +Prefix argument selects that many (or that many more) defuns. +Negative prefix arg flips the direction of selection. Also, +'mark-defun' between defuns correctly selects N following defuns (or +-N previous for negative arguments). Finally, comments preceding the +defun are selected unless they are separated from the defun by a blank +line. + +--- +** New command 'replace-buffer-contents'. +This command replaces the contents of the accessible portion of the +current buffer with the contents of the accessible portion of a +different buffer while keeping point, mark, markers, and text +properties as intact as possible. + ++++ +** New commands 'apropos-local-variable' and 'apropos-local-value'. +These are buffer-local versions of 'apropos-variable' and +'apropos-value', respectively. They show buffer-local variables whose +names and values, respectively, match a given pattern. + ++++ +** More user control of reordering bidirectional text for display. +The two new variables, 'bidi-paragraph-start-re' and +'bidi-paragraph-separate-re', allow customization of what exactly are +paragraphs, for the purposes of bidirectional display. + +--- +** 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). + + +* Changes in Specialized Modes and Packages in Emacs 26.1 + +--- +** Emacs 26.1 comes with Org v9.1.4. +See the file ORG-NEWS for user-visible changes in Org. + +--- +** New function 'cl-generic-p'. + +** Dired + ++++ +*** You can answer 'all' in 'dired-do-delete' to delete recursively all +remaining directories without more prompts. + ++++ +*** Dired supports wildcards in the directory part of the file names. + ++++ +*** You can now use '`?`' in 'dired-do-shell-command'. +It gets replaced by the current file name, like ' ? '. + ++++ +*** A new option 'dired-always-read-filesystem' defaulting to nil. +If non-nil, buffers visiting files are reverted before they are +searched; for instance, in 'dired-mark-files-containing-regexp' a +non-nil value of this option means the file is revisited in a +temporary buffer; this temporary buffer is the actual buffer searched: +the original buffer visiting the file is not modified. + +--- +*** Users can now customize mouse clicks in Dired in a more flexible way. +The new command 'dired-mouse-find-file' can be bound to a mouse click +and used to visit files/directories in Dired in the selected window. +The new command 'dired-mouse-find-file-other-frame' similarly visits +files/directories in another frame. You can write your own commands +that invoke 'dired-mouse-find-file' with non-default optional +arguments, to tailor the effects of mouse clicks on file names in +Dired buffers. + ++++ +*** In wdired, when editing files to contain slash characters, +the resulting directories are automatically created. Whether to do +this is controlled by the 'wdired-create-parent-directories' variable. + ++++ +*** 'W' is now bound to 'browse-url-of-dired-file', and is useful for +viewing HTML files and the like. + +--- +*** New variable 'dired-clean-confirm-killing-deleted-buffers' +controls whether Dired asks to kill buffers visiting deleted files and +directories. The default is t, so Dired asks for confirmation, to +keep previous behavior. + +--- +** html2text is now marked obsolete. + +--- +** smerge-refine-regions can refine regions in separate buffers. + +--- +** Info menu and index completion uses substring completion by default. +This can be customized via the 'info-menu' category in +'completion-category-overrides'. + ++++ +** The ancestor buffer is shown by default in 3-way merges. +A new option 'ediff-show-ancestor' and a new toggle +'ediff-toggle-show-ancestor'. + +--- +** TeX: Add luatex and xetex as alternatives to pdftex + +** Electric-Buffer-menu + ++++ +*** Key 'U' is bound to 'Buffer-menu-unmark-all' and key 'M-DEL' is +bound to 'Buffer-menu-unmark-all-buffers'. + ++++ +** hideshow mode got four key bindings that are analogous to outline +mode bindings: 'C-c @ C-a', 'C-c @ C-t', 'C-c @ C-d', and 'C-c @ C-e'. + +** bs + +--- +*** Two new commands 'bs-unmark-all', bound to 'U', and +'bs-unmark-previous', bound to <backspace>. + +** Buffer-menu + ++++ +*** Two new commands 'Buffer-menu-unmark-all', bound to 'U' and +'Buffer-menu-unmark-all-buffers', bound to 'M-DEL'. + +--- +** Checkdoc + +*** 'checkdoc-arguments-in-order-flag' now defaults to nil. + +** Gnus + +--- +*** The ~/.newsrc file will now only be saved if the native select +method is an NNTP select method. + ++++ +*** A new command for sorting articles by readedness marks has been +added: 'C-c C-s C-m C-m'. + ++++ +*** In 'message-citation-line-format' the '%Z' format is now the time +zone name instead of the numeric form. The '%z' format continues to +be the numeric form. The new behavior is compatible with +'format-time-string'. + +** Ibuffer + +--- +*** New command 'ibuffer-jump'. + +--- +*** New filter commands 'ibuffer-filter-by-basename', +'ibuffer-filter-by-file-extension', 'ibuffer-filter-by-directory', +'ibuffer-filter-by-starred-name', 'ibuffer-filter-by-modified' +and 'ibuffer-filter-by-visiting-file'; bound respectively +to '/b', '/.', '//', '/*', '/i' and '/v'. + +--- +*** Two new commands 'ibuffer-filter-chosen-by-completion' +and 'ibuffer-and-filter', the second bound to '/&'. + +--- +*** The commands 'ibuffer-pop-filter', 'ibuffer-pop-filter-group', +'ibuffer-or-filter' and 'ibuffer-filter-disable' have the alternative +bindings '/<up>', '/S-<up>', '/|' and '/DEL', respectively. + +--- +*** The data format specifying filters has been extended to allow +explicit logical 'and', and a more flexible form for logical 'not'. +See 'ibuffer-filtering-qualifiers' doc string for full details. + +--- +*** A new command 'ibuffer-copy-buffername-as-kill'; bound +to 'B'. + +--- +*** New command 'ibuffer-change-marks'; bound to '* c'. + +--- +*** A new command 'ibuffer-mark-by-locked' to mark +all locked buffers; bound to '% L'. + +--- +*** A new option 'ibuffer-locked-char' to indicate +locked buffers; Ibuffer shows a new column displaying +'ibuffer-locked-char' for locked buffers. + +--- +*** A new command 'ibuffer-unmark-all-marks' to unmark +all buffers without asking confirmation; bound to +'U'; 'ibuffer-do-replace-regexp' bound to 'r'. + +--- +*** A new command 'ibuffer-mark-by-content-regexp' to mark buffers +whose content matches a regexp; bound to '% g'. + +--- +*** Two new options 'ibuffer-never-search-content-name' and +'ibuffer-never-search-content-mode' used by +'ibuffer-mark-by-content-regexp'. + +** Browse-URL + +--- +*** Support for opening links to man pages in Man or WoMan mode. + +** Comint + +--- +*** New user option 'comint-move-point-for-matching-input' to control +where to place point after 'C-c M-r' and 'C-c M-s'. + ++++ +*** New user option 'comint-terminfo-terminal'. +This option allows control of the value of the TERM environment +variable Emacs puts into the environment of the Comint mode and its +derivatives, such as Shell mode and Compilation Shell minor-mode. The +default is "dumb", for compatibility with previous behavior. + +** Compilation mode + +--- +*** Messages from CMake are now recognized. + ++++ +*** The number of errors, warnings, and informational messages is now +displayed in the mode line. These are updated as compilation +proceeds. + +** Grep + +--- +*** Grep commands will now use GNU grep's '--null' option if +available, which allows distinguishing the filename from contents if +they contain colons. This can be controlled by the new custom option +'grep-use-null-filename-separator'. + +--- +*** The grep/rgrep/lgrep functions will now ask about saving files +before running. This is controlled by the 'grep-save-buffers' +variable. + +** Edebug + +--- +*** Edebug can be prevented from pausing 1 second after reaching a +breakpoint (e.g. with "f" and "o") by customizing the new option +'edebug-sit-on-break'. + ++++ +*** New customizable option 'edebug-max-depth'. +This allows to enlarge the maximum recursion depth when instrumenting +code. + +** Eshell + +--- +*** 'eshell-input-filter's value is now a named function +'eshell-input-filter-default', and has a new custom option +'eshell-input-filter-initial-space' to ignore adding commands prefixed +with blank space to eshell history. + +** EUDC + +--- +*** Backward compatibility support for BBDB versions less than 3 +(i.e., BBDB 2.x) is deprecated and will likely be removed in the next +major release of Emacs. Users of BBDB 2.x should plan to upgrade to +BBDB 3.x. + +** eww + ++++ +*** New 'M-RET' command for opening a link at point in a new eww buffer. + ++++ +*** A new 's' command for switching to another eww buffer via the minibuffer. + +--- +*** The 'o' command ('shr-save-contents') has moved to 'O' to avoid collision +with the 'o' command from 'image-map'. + ++++ +*** A new command 'C' ('eww-toggle-colors') can be used to toggle +whether to use the HTML-specified colors or not. The user can also +customize the 'shr-use-colors' variable. + +--- +*** Images that are being loaded are now marked with gray +"placeholder" images of the size specified by the HTML. They are then +replaced by the real images asynchronously, which will also now +respect width/height HTML specs (unless they specify widths/heights +bigger than the current window). + +--- +*** The 'w' command on links is now 'shr-maybe-probe-and-copy-url'. +'shr-copy-url' now only copies the url at point; users who wish to +avoid accidentally accessing remote links may rebind 'w' and 'u' in +'eww-link-keymap' to it. + +** Ido + +--- +*** The commands 'find-alternate-file-other-window', +'dired-other-window', 'dired-other-frame', and +'display-buffer-other-window' are now remapped to Ido equivalents if +Ido mode is active. + +** Images + ++++ +*** Images are automatically scaled before displaying based on the +'image-scaling-factor' variable (if Emacs supports scaling the images +in question). + ++++ +*** It's now possible to specify aspect-ratio preserving combinations +of :width/:max-height and :height/:max-width keywords. In either +case, the "max" keywords win. (Previously some combinations would, +depending on the aspect ratio of the image, just be ignored and in +other instances this would lead to the aspect ratio not being +preserved.) + ++++ +*** Images inserted with 'insert-image' and related functions get a +keymap put into the text properties (or overlays) that span the +image. This keymap binds keystrokes for manipulating size and +rotation, as well as saving the image to a file. These commands are +also available in 'image-mode'. + ++++ +*** A new library for creating and manipulating SVG images has been +added. See the "(elisp) SVG Images" section in the ELisp reference +manual for details. + ++++ +*** New setf-able function to access and set image parameters is +provided: 'image-property'. + +--- +*** New commands 'image-scroll-left' and 'image-scroll-right' +for 'image-mode' that complement 'image-scroll-up' and +'image-scroll-down': they have the same prefix arg behavior and stop +at image boundaries. + +** Image-Dired + +--- +*** Now provides a minor mode 'image-dired-minor-mode' which replaces +the function 'image-dired-setup-dired-keybindings'. + +--- +*** Thumbnail generation is now asynchronous. +The number of concurrent processes is limited by the variable +'image-dired-thumb-job-limit'. + +--- +*** 'image-dired-thumbnail-storage' has a new option 'standard-large' +for generating 256x256 thumbnails according to the Thumbnail Managing +Standard. + +--- +*** Inherits movement keys from 'image-mode' for viewing full images. +This includes the usual char, line, and page movement commands. + +--- +*** All the -options types have been changed to argument lists +instead of shell command strings. This change affects +'image-dired-cmd-create-thumbnail-options', +'image-dired-cmd-create-temp-image-options', +'image-dired-cmd-rotate-thumbnail-options', +'image-dired-cmd-rotate-original-options', +'image-dired-cmd-write-exif-data-options', +'image-dired-cmd-read-exif-data-options', and introduces +'image-dired-cmd-pngnq-options', 'image-dired-cmd-pngcrush-options', +'image-dired-cmd-create-standard-thumbnail-options'. + +--- +*** Recognizes more tools by default, including pngnq-s9 and OptiPNG. + +--- +*** 'find-file' and related commands now work on thumbnails and +displayed images, providing a default argument of the original file name +via an addition to 'file-name-at-point-functions'. + +--- +** The default 'Info-default-directory-list' no longer checks some obsolete +directory suffixes (gnu, gnu/lib, gnu/lib/emacs, emacs, lib, lib/emacs) +when searching for info directories. + ++++ +** The commands that add ChangeLog entries now prefer a VCS root directory +for the ChangeLog file, if none already exists. Customize +'change-log-directory-files' to nil for the old behavior. + +--- +** Support for non-string values of 'time-stamp-format' has been removed. + +** Message + +--- +*** 'message-use-idna' now defaults to t (because Emacs comes with +built-in IDNA support now). + +--- +*** When sending HTML messages with embedded images, and you have +exiftool installed, and you rotate images with EXIF data (i.e., +JPEGs), the rotational information will be inserted into the outgoing +image in the message. (The original image will not have its +orientation affected.) + +--- +*** The 'message-valid-fqdn-regexp' variable has been removed, since +there are now top-level domains added all the time. Message will no +longer warn about sending emails to top-level domains it hasn't heard +about. + +--- +*** 'message-beginning-of-line' (bound to 'C-a') understands folded headers. +In 'visual-line-mode' it will look for the true beginning of a header +while in non-'visual-line-mode' it will move the point to the indented +header's value. + +** Package + ++++ +*** The new variable 'package-gnupghome-dir' has been added to control +where the GnuPG home directory (used for signature verification) is +located and whether GnuPG's option '--homedir' is used or not. + +--- +*** Deleting a package no longer respects 'delete-by-moving-to-trash'. + +** Tramp + ++++ +*** The method part of remote file names is mandatory now. +A valid remote file name starts with "/method:host:" or +"/method:user@host:". + ++++ +*** The new pseudo method "-" is a marker for the default method. +"/-::" is the shortest remote file name then. + ++++ +*** The command 'tramp-change-syntax' allows to choose an alternative +remote file name syntax. + ++++ +*** New connection method "sg", which supports editing files under a +different group ID. + ++++ +*** New connection method "doas" for OpenBSD hosts. + ++++ +*** New connection method "gdrive", which allows to access Google +Drive onsite repositories. + ++++ +*** Gateway methods in Tramp have been removed. +Instead, the Tramp manual documents how to configure ssh and PuTTY +accordingly. + ++++ +*** Setting the "ENV" environment variable in +'tramp-remote-process-environment' enables reading of shell +initialization files. + +--- +*** Tramp is able now to send SIGINT to remote asynchronous processes. + +--- +*** Variable 'tramp-completion-mode' is obsoleted. + +--- +** 'auto-revert-use-notify' is set back to t in 'global-auto-revert-mode'. + +** JS mode + +--- +*** JS mode now sets 'comment-multi-line' to t. + +--- +*** New variable 'js-indent-align-list-continuation', when set to nil, +will not align continuations of bracketed lists, but will indent them +by the fixed width 'js-indent-level'. + +** CSS mode + +--- +*** Support for completing attribute values, at-rules, bang-rules, +HTML tags, classes and IDs using the 'completion-at-point' command. +Completion candidates for HTML classes and IDs are retrieved from open +HTML mode buffers. + +--- +*** CSS mode now binds 'C-h S' to a function that will show +information about a CSS construct (an at-rule, property, pseudo-class, +pseudo-element, with the default being guessed from context). By +default the information is looked up on the Mozilla Developer Network, +but this can be customized using 'css-lookup-url-format'. + +--- +*** CSS colors are fontified using the color they represent as the +background. For instance, #ff0000 would be fontified with a red +background. + ++++ +** Emacs now supports character name escape sequences in character and +string literals. The syntax variants '\N{character name}' and +'\N{U+code}' are supported. + ++++ +** Prog mode has some support for multi-mode indentation. +This allows better indentation support in modes that support multiple +programming languages in the same buffer, like literate programming +environments or ANTLR programs with embedded Python code. + +A major mode can provide indentation context for a sub-mode. To +support this, modes should use 'prog-first-column' instead of a +literal zero and avoid calling 'widen' in their indentation functions. +See the node "(elisp) Mode-Specific Indent" in the ELisp manual for +more details. + +** ERC + +--- +*** New variable 'erc-default-port-tls' used to connect to TLS IRC +servers. + +** URL + ++++ +*** The new function 'url-cookie-delete-cookie' can be used to +programmatically delete all cookies, or cookies from a specific +domain. + ++++ +*** 'url-retrieve-synchronously' now takes an optional timeout parameter. + +--- +*** The URL package now supports HTTPS over proxies supporting CONNECT. + ++++ +*** 'url-user-agent' now defaults to 'default', and the User-Agent +string is computed dynamically based on 'url-privacy-level'. + +** VC and related modes + ++++ +*** 'vc-dir-mode' now binds 'vc-log-outgoing' to 'O'; and has various +branch-related commands on a keymap bound to 'B'. + ++++ +*** 'vc-region-history' is now bound to 'C-x v h', replacing the older +'vc-insert-headers' binding. + +** CC mode + +--- +*** Opening a .h file will turn C or C++ mode depending on language used. +This is done with the help of the 'c-or-c++-mode' function, which +analyzes buffer contents to infer whether it's a C or C++ source file. + +--- +** New option 'cpp-message-min-time-interval' to allow user control +of progress messages in cpp.el. + +--- +** New DNS mode command 'dns-mode-ipv6-to-nibbles' to convert IPv6 addresses +to a format suitable for reverse lookup zone files. + +** Ispell + ++++ +*** Enchant is now supported as a spell-checker. + +Enchant is a meta-spell-checker that uses providers such as Hunspell +to do the actual checking. With it, users can use spell-checkers not +directly supported by Emacs, such as Voikko, Hspell and AppleSpell, +more easily share personal word-lists with other programs, and +configure different spelling-checkers for different languages. +(Version 2.1.0 or later of Enchant is required.) + +** Flymake + ++++ +*** Flymake has been completely redesigned + +Flymake now annotates arbitrary buffer regions, not just lines. It +supports arbitrary diagnostic types, not just errors and warnings (see +variable 'flymake-diagnostic-types-alist'). + +It also supports multiple simultaneous backends, meaning that you can +check your buffer from different perspectives (see variable +'flymake-diagnostic-functions'). Backends for Emacs Lisp mode are +provided. + +The old Flymake behavior is preserved in the so-called "legacy +backend", which has been updated to benefit from the new UI features. + +** Term + +--- +*** `term-char-mode' now makes its buffer read-only. + +The buffer is made read-only to prevent changes from being made by +anything other than the process filter; and movements of point away +from the process mark are counter-acted so that the cursor is in the +correct position after each command. This is needed to avoid states +which are inconsistent with the state of the terminal understood by +the inferior process. + +New user options `term-char-mode-buffer-read-only' and +`term-char-mode-point-at-process-mark' control these behaviors, and +are non-nil by default. Customize these options to nil if you want +the previous behavior. + +** Xref + ++++ +*** When an *xref* buffer is needed, 'TAB' quits and jumps to an xref. + +A new command 'xref-quit-and-goto-xref', bound to 'TAB' in *xref* +buffers, quits the window before jumping to the destination. In many +situations, the intended window configuration is restored, just as if +the *xref* buffer hadn't been necessary in the first place. + + +* New Modes and Packages in Emacs 26.1 + +--- +** New Elisp data-structure library 'radix-tree'. + +--- +** New library 'xdg' with utilities for some XDG standards and specs. + +** HTML + ++++ +*** A new submode of 'html-mode', 'mhtml-mode', is now the default +mode for *.html files. This mode handles indentation, +fontification, and commenting for embedded JavaScript and CSS. + +--- +** New mode 'conf-toml-mode' is a sub-mode of 'conf-mode', specialized +for editing TOML files. + +--- +** New mode 'conf-desktop-mode' is a sub-mode of 'conf-unix-mode', +specialized for editing freedesktop.org desktop entries. + +--- +** New minor mode 'pixel-scroll-mode' provides smooth pixel-level scrolling. + +--- +** New major mode 'less-css-mode' (a minor variant of 'css-mode') for +editing Less files. + + +* Incompatible Lisp Changes in Emacs 26.1 + +--- +** 'password-data' is now a hash-table so that 'password-read' can use +any object for the 'key' argument. + ++++ +** Command 'dired-mark-extension' now automatically prepends a '.' to the +extension when not present. The new command 'dired-mark-suffix' behaves +similarly but it doesn't prepend a '.'. + ++++ +** Certain cond/pcase/cl-case forms are now compiled using a faster jump +table implementation. This uses a new bytecode op 'switch', which +isn't compatible with previous Emacs versions. This functionality can +be disabled by setting 'byte-compile-cond-use-jump-table' to nil. + ++++ +** If 'comment-auto-fill-only-comments' is non-nil, 'auto-fill-function' +is now called only if either no comment syntax is defined for the +current buffer or the self-insertion takes place within a comment. + +--- +** The alist 'ucs-names' is now a hash table. + +--- +** 'if-let' and 'when-let' are subsumed by 'if-let*' and 'when-let*'. +The incumbent 'if-let' and 'when-let' are now marked obsolete. +'if-let*' and 'when-let*' do not accept the single tuple special case. +New macro 'and-let*' is an implementation of the Scheme SRFI-2 syntax +of the same name. 'if-let*' and 'when-let*' now accept the same +binding syntax as 'and-let*'. + +--- +** 'C-up', 'C-down', 'C-left' and 'C-right' are now defined in term +mode to send the same escape sequences that xterm does. This makes +things like 'forward-word' in readline work. + +--- +** Customizable variable 'query-replace-from-to-separator' +now doesn't propertize the string value of the separator. +Instead, text properties are added by 'query-replace-read-from'. +Additionally, the new nil value restores pre-24.5 behavior +of not providing replacement pairs via the history. + +--- +** Some obsolete functions, variables, and faces have been removed: + +*** 'make-variable-frame-local'. Variables cannot be frame-local any more. + +*** From subr.el: 'window-dot', 'set-window-dot', 'read-input', +'show-buffer', 'eval-current-buffer', 'string-to-int'. + +*** 'icomplete-prospects-length'. + +*** All the default-FOO variables that hold the default value of the +FOO variable. Use 'default-value' and 'setq-default' to access and +change FOO, respectively. The exhaustive list of removed variables is: +'default-mode-line-format', 'default-header-line-format', +'default-line-spacing', 'default-abbrev-mode', 'default-ctl-arrow', +'default-truncate-lines', 'default-left-margin', 'default-tab-width', +'default-case-fold-search', 'default-left-margin-width', +'default-right-margin-width', 'default-left-fringe-width', +'default-right-fringe-width', 'default-fringes-outside-margins', +'default-scroll-bar-width', 'default-vertical-scroll-bar', +'default-indicate-empty-lines', 'default-indicate-buffer-boundaries', +'default-fringe-indicator-alist', 'default-fringe-cursor-alist', +'default-scroll-up-aggressively', 'default-scroll-down-aggressively', +'default-fill-column', 'default-cursor-type', +'default-cursor-in-non-selected-windows', +'default-buffer-file-coding-system', 'default-major-mode', and +'default-enable-multibyte-characters'. + +*** Many variables obsoleted in 22.1 referring to face symbols. + ++++ +** The variable 'text-quoting-style' is now a customizable option. It +controls whether to and how to translate ASCII quotes in messages and +help output. Its possible values and their semantics remain unchanged +from Emacs 25. In particular, when this variable's value is 'grave', +all quotes in formats are output as-is. + +--- +** Functions like 'check-declare-file' and 'check-declare-directory' +now generate less chatter and more-compact diagnostics. The auxiliary +function 'check-declare-errmsg' has been removed. + ++++ +** The regular expression character class '[:blank:]' now matches +Unicode horizontal whitespace as defined in the Unicode Technical +Standard #18. If you only want to match space and tab, use '[ \t]' +instead. + ++++ +** 'min' and 'max' no longer round their results. +Formerly, they returned a floating-point value if any argument was +floating-point, which was sometimes numerically incorrect. For +example, on a 64-bit host (max 1e16 10000000000000001) now returns its +second argument instead of its first. + ++++ +** The variable 'old-style-backquotes' has been made internal and +renamed to 'lread--old-style-backquotes'. No user code should use +this variable. + +--- +** To avoid confusion caused by "smart quotes", the reader no longer +accepts Lisp symbols which begin with the following quotation +characters: ‘’‛“”‟〞＂＇, unless they are escaped with backslash. + ++++ +** 'default-file-name-coding-system' now defaults to a coding system +that does not process CRLF. For example, it defaults to 'utf-8-unix' +instead of to 'utf-8'. Before this change, Emacs would sometimes +mishandle file names containing these control characters. + ++++ +** 'file-attributes', 'file-symlink-p' and 'make-symbolic-link' no +longer quietly mutate the target of a local symbolic link, so that +Emacs can access and copy them reliably regardless of their contents. +The following changes are involved. + +--- +*** 'file-attributes' and 'file-symlink-p' no longer prepend "/:" to +symbolic links whose targets begin with "/" and contain ":". For +example, if a symbolic link "x" has a target "/y:z:", '(file-symlink-p +"x")' now returns "/y:z:" rather than "/:/y:z:". + +--- +*** 'make-symbolic-link' no longer looks for file name handlers of +target when creating a symbolic link. For example, +'(make-symbolic-link "/y:z:" "x")' now creates a symbolic link to +"/y:z:" instead of failing. + ++++ +*** 'make-symbolic-link' removes the remote part of a link target if +target and newname have the same remote part. For example, +'(make-symbolic-link "/x:y:a" "/x:y:b")' creates a link with the +literal string "a"; and '(make-symbolic-link "/x:y:a" "/x:z:b")' +creates a link with the literal string "/x:y:a" instead of failing. + ++++ +*** 'make-symbolic-link' now expands a link target with leading "~" +only when the optional third arg is an integer, as when invoked +interactively. For example, '(make-symbolic-link "~y" "x")' now +creates a link with target the literal string "~y"; to get the old +behavior, use '(make-symbolic-link (expand-file-name "~y") "x")'. To +avoid this expansion in interactive use, you can now prefix the link +target with "/:". For example, '(make-symbolic-link "/:~y" "x" 1)' +now creates a link to literal "~y". + ++++ +** 'file-truename' returns a quoted file name if the target of a +symbolic link has remote file name syntax. + ++++ +** Module functions are now implemented slightly differently; in +particular, the function 'internal--module-call' has been removed. +Code that depends on undocumented internals of the module system might +break. + +--- +** The argument LOCKNAME of 'write-region' is propagated to file name +handlers now. + +--- +** When built against recent versions of GTK+, Emacs always uses +gtk_window_move for moving frames and ignores the value of the +variable 'x-gtk-use-window-move'. The variable is now obsolete. + ++++ +** Several functions that create or rename files now treat their +destination argument specially only when it is a directory name, i.e., +when it ends in '/' on GNU and other POSIX-like systems. When the +destination argument D of one of these functions is an existing +directory and the intent is to act on an entry in that directory, D +should now be a directory name. For example, (rename-file "e" "f/") +renames to 'f/e'. Although this formerly happened sometimes even when +D was not a directory name, as in (rename-file "e" "f") where 'f' +happened to be a directory, the old behavior often contradicted the +documentation and had inherent races that led to security holes. A +call like (rename-file C D) that used the old, undocumented behavior +can be written as (rename-file C (file-name-as-directory D)), a +formulation portable to both older and newer versions of Emacs. +Affected functions include 'add-name-to-file', 'copy-directory', +'copy-file', 'format-write-file', 'gnus-copy-file', +'make-symbolic-link', 'rename-file', 'thumbs-rename-images', and +'write-file'. + +--- +** The list returned by 'overlays-at' is now in decreasing priority order. +The documentation of this function always said the order should be +that of decreasing priority, if the 2nd argument of the function is +non-nil, but the code returned the list in the increasing order of +priority instead. Now the code does what the documentation says it +should do. + ++++ +** 'format' now avoids allocating a new string in more cases. +'format' was previously documented to return a newly-allocated string, +but this documentation was not correct, as (eq x (format x)) returned +t when x was the empty string. 'format' is no longer documented to +return a newly-allocated string, and the implementation now takes +advantage of the doc change to avoid making copies of strings in +common cases like (format "foo") and (format "%s" "foo"). + +--- +** 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. + +--- +** Using '&rest' or '&optional' incorrectly is now an error. +For example giving '&optional' without a following variable, or +passing '&optional' multiple times: + + (defun foo (&optional &rest x)) + (defun bar (&optional &optional x)) + +Previously, Emacs would just ignore the extra keyword, or give +incorrect results in certain cases. + +--- +** The pinentry.el library has been removed. +That package (and the corresponding change in GnuPG and pinentry) +was intended to provide a way to input passphrase through Emacs with +GnuPG 2.0. However, the change to support that was only implemented +in GnuPG >= 2.1 and didn't get backported to GnuPG 2.0. And with +GnuPG 2.1 and later, pinentry.el is not needed at all. So the +library was useless, and we removed it. GnuPG 2.0 is no longer +supported by the upstream project. + +To adapt to the change, you may need to set 'epa-pinentry-mode' to the +symbol 'loopback'. + +Note that previously, it was said that passphrase input through +minibuffer would be much less secure than other graphical pinentry +programs. However, these days the difference is insignificant: the +'read-password' function sufficiently protects input from leakage to +message logs. Emacs still doesn't use secure memory to protect +passphrases, but it was also removed from other pinentry programs as +the attack is unrealistic on modern computer systems which don't +utilize swap memory usually. + + +* Lisp Changes in Emacs 26.1 + ++++ +** The function 'assoc' now takes an optional third argument TESTFN. +This argument, when non-nil, is used for comparison instead of +'equal'. + ++++ +** New optional argument TESTFN in 'alist-get', 'map-elt' and 'map-put'. +If non-nil, the argument specifies a function to use for comparison, +instead of, respectively, 'assq' and 'eql'. + ++++ +** New function 'seq-set-equal-p' to check if SEQUENCE1 and SEQUENCE2 +contain the same elements, regardless of the order. + ++++ +** The new function 'mapbacktrace' applies a function to all frames of +the current stack trace. + ++++ +** The new function 'file-name-case-insensitive-p' tests whether a +given file is on a case-insensitive filesystem. + ++++ +** Several accessors for the value returned by 'file-attributes' +have been added. They are: 'file-attribute-type', +'file-attribute-link-number', 'file-attribute-user-id', +'file-attribute-group-id', 'file-attribute-access-time', +'file-attribute-modification-time', +'file-attribute-status-change-time', 'file-attribute-size', +'file-attribute-modes', 'file-attribute-inode-number', +'file-attribute-device-number' and 'file-attribute-collect'. + ++++ +** The new function 'buffer-hash' computes a fast, non-consing hash of +a buffer's contents. + ++++ +** 'interrupt-process' now consults the list 'interrupt-process-functions', +to determine which function has to be called in order to deliver the +SIGINT signal. This allows Tramp to send the SIGINT signal to remote +asynchronous processes. The hitherto existing implementation has been +moved to 'internal-default-interrupt-process'. + ++++ +** The new function 'read-multiple-choice' prompts for multiple-choice +questions, with a handy way to display help texts. + +--- +** 'comment-indent-function' values may now return a cons to specify a +range of indentation. + ++++ +** New optional argument TEXT in 'make-temp-file'. + +--- +** New function 'define-symbol-prop'. + ++++ +** New function 'secure-hash-algorithms' to list the algorithms that +'secure-hash' supports. +See the node "(elisp) Checksum/Hash" in the ELisp manual for details. + ++++ +** Emacs now exposes the GnuTLS cryptographic API with the functions +'gnutls-macs' and 'gnutls-hash-mac'; 'gnutls-digests' and +'gnutls-hash-digest'; 'gnutls-ciphers' and 'gnutls-symmetric-encrypt' +and 'gnutls-symmetric-decrypt'. +See the node "(elisp) GnuTLS Cryptography" in the ELisp manual for details. + ++++ +** The function 'gnutls-available-p' now returns a list of capabilities +supported by the GnuTLS library used by Emacs. + ++++ +** Emacs now supports records for user-defined types, via the new +functions 'make-record', 'record', and 'recordp'. Records are now +used internally to represent cl-defstruct and defclass instances, for +example. + +If your program defines new record types, you should use +package-naming conventions for naming those types. This is so any +potential conflicts with other types are avoided. + ++++ +** 'save-some-buffers' now uses 'save-some-buffers-default-predicate' +to decide which buffers to ask about, if the PRED argument is nil. +The default value of 'save-some-buffers-default-predicate' is nil, +which means ask about all file-visiting buffers. + +--- +** string-(to|as|make)-(uni|multi)byte are now declared obsolete. + ++++ +** New variable 'while-no-input-ignore-events' which allow +setting which special events 'while-no-input' should ignore. +It is a list of symbols. + +--- +** New function 'undo-amalgamate-change-group' to get rid of +undo-boundaries between two states. + +--- +** New var 'definition-prefixes' is a hash table mapping prefixes to +the files where corresponding definitions can be found. This can be +used to fetch definitions that are not yet loaded, for example for +'C-h f'. + +--- +** New var 'syntax-ppss-table' to control the syntax-table used in +'syntax-ppss'. + ++++ +** 'define-derived-mode' can now specify an :after-hook form, which +gets evaluated after the new mode's hook has run. This can be used to +incorporate configuration changes made in the mode hook into the +mode's setup. + +--- +** Autoload files can be generated without timestamps, +by setting 'autoload-timestamps' to nil. +FIXME As an experiment, nil is the current default. +If no insurmountable problems before next release, it can stay that way. + +--- +** 'gnutls-boot' now takes a parameter ':complete-negotiation' that +says that negotiation should complete even on non-blocking sockets. + +--- +** There is now a new variable 'flyspell-sort-corrections-function' +that allows changing the way corrections are sorted. + +--- +** The new command 'fortune-message' has been added, which displays +fortunes in the echo area. + ++++ +** New function 'func-arity' returns information about the argument list +of an arbitrary function. This generalizes 'subr-arity' for functions +that are not built-in primitives. We recommend using this new +function instead of 'subr-arity'. + +--- +** New function 'region-bounds' can be used in the interactive spec +to provide region boundaries (for rectangular regions more than one) +to an interactively callable function as a single argument instead of +two separate arguments 'region-beginning' and 'region-end'. + ++++ +** 'parse-partial-sexp' state has a new element. Element 10 is +non-nil when the last character scanned might be the first character +of a two character construct, i.e., a comment delimiter or escaped +character. Its value is the syntax of that last character. + ++++ +** 'parse-partial-sexp's state, element 9, has now been confirmed as +permanent and documented, and may be used by Lisp programs. Its value +is a list of currently open parenthesis positions, starting with the +outermost parenthesis. + +--- +** 'read-color' will now display the color names using the color itself +as the background color. + +--- +** The function 'redirect-debugging-output' now works on platforms +other than GNU/Linux. + ++++ +** The new function 'string-version-lessp' compares strings by +interpreting consecutive runs of numerical characters as numbers, and +compares their numerical values. According to this predicate, +"foo2.png" is smaller than "foo12.png". + +--- +** Numeric comparisons and 'logb' no longer return incorrect answers +due to internal rounding errors. For example, '(< most-positive-fixnum +(+ 1.0 most-positive-fixnum))' now correctly returns t on 64-bit hosts. + +--- +** The functions 'ffloor', 'fceiling', 'ftruncate' and 'fround' now +accept only floating-point arguments, as per their documentation. +Formerly, they quietly accepted integer arguments and sometimes +returned nonsensical answers, e.g., '(< N (ffloor N))' could return t. + +--- +** On hosts like GNU/Linux x86-64 where a 'long double' fraction +contains at least EMACS_INT_WIDTH - 3 bits, 'format' no longer returns +incorrect answers due to internal rounding errors when formatting +Emacs integers with '%e', '%f', or '%g' conversions. For example, on +these hosts '(eql N (string-to-number (format "%.0f" N)))' now returns +t for all Emacs integers N. + +--- +** Calls that accept floating-point integers (for use on hosts with +limited integer range) now signal an error if arguments are not +integral. For example '(decode-char 'ascii 0.5)' now signals an error. + ++++ +** The new function 'char-from-name' converts a Unicode name string +to the corresponding character code. + ++++ +** New functions 'sxhash-eq' and 'sxhash-eql' return hash codes of a +Lisp object suitable for use with 'eq' and 'eql' correspondingly. If +two objects are 'eq' ('eql'), then the result of 'sxhash-eq' +('sxhash-eql') on them will be the same. + ++++ +** Function 'sxhash' has been renamed to 'sxhash-equal' for +consistency with the new functions. For compatibility, 'sxhash' +remains as an alias to 'sxhash-equal'. + ++++ +** 'make-hash-table' now defaults to a rehash threshold of 0.8125 +instead of 0.8, to avoid rounding glitches. + ++++ +** New function 'add-variable-watcher' can be used to call a function +when a symbol's value is changed. This is used to implement the new +debugger command 'debug-on-variable-change'. + ++++ +** Time conversion functions that accept a time zone rule argument now +allow it to be OFFSET or a list (OFFSET ABBR), where the integer +OFFSET is a count of seconds east of Universal Time, and the string +ABBR is a time zone abbreviation. The affected functions are +'current-time-string', 'current-time-zone', 'decode-time', +'format-time-string', and 'set-time-zone-rule'. + ++++ +** 'format-time-string' now formats '%q' to the calendar quarter. + ++++ +** New built-in function 'mapcan'. +It avoids unnecessary consing (and garbage collection). + ++++ +** 'car' and 'cdr' compositions 'cXXXr' and 'cXXXXr' are now part of Elisp. + ++++ +** 'gensym' is now part of Elisp. + +--- +** Low-level list functions like 'length' and 'member' now do a better +job of signaling list cycles instead of looping indefinitely. + ++++ +** The new functions 'make-nearby-temp-file' and 'temporary-file-directory' +can be used for creation of temporary files on remote or mounted directories. + ++++ +** On GNU platforms when operating on a local file, 'file-attributes' +no longer suffers from a race when called while another process is +altering the filesystem. On non-GNU platforms 'file-attributes' +attempts to detect the race, and returns nil if it does so. + ++++ +** The new function 'file-local-name' can be used to specify arguments +of remote processes. + ++++ +** The new functions 'file-name-quote', 'file-name-unquote' and +'file-name-quoted-p' can be used to quote / unquote file names with +the prefix "/:". + ++++ +** The new error 'file-missing', a subcategory of 'file-error', is now +signaled instead of 'file-error' if a file operation acts on a file +that does not exist. + ++++ +** The function 'delete-directory' no longer signals an error when +operating recursively and when some other process deletes the directory +or its files before 'delete-directory' gets to them. + ++++ +** New error type 'user-search-failed' like 'search-failed' but +avoids debugger like 'user-error'. + ++++ +** The function 'line-number-at-pos' now takes a second optional +argument 'absolute'. If this parameter is nil, the default, this +function keeps on returning the line number taking potential narrowing +into account. If this parameter is non-nil, the function ignores +narrowing and returns the absolute line number. + +--- +** The function 'color-distance' now takes a second optional argument +'metric'. When non-nil, it should be a function of two arguments that +accepts two colors and returns a number. + +** Changes in Frame and Window Handling + ++++ +*** Resizing a frame no longer runs 'window-configuration-change-hook'. +'window-size-change-functions' should be used instead. + ++++ +*** The new function 'frame-size-changed-p' can tell whether a frame has +been resized since the last time 'window-size-change-functions' has been +run. + ++++ +*** The function 'frame-geometry' now also returns the width of a +frame's outer border. + ++++ +*** New frame parameters and changed semantics for older ones: + ++++ +**** 'z-group' positions a frame above or below all others. + ++++ +**** 'min-width' and 'min-height' specify the absolute minimum size of a +frame. + ++++ +**** 'parent-frame' makes a frame the child frame of another Emacs +frame. The section "(elisp) Child Frames" in the ELisp manual +describes the intrinsics of that relationship. + ++++ +**** 'delete-before' triggers deletion of one frame before that of +another. + ++++ +**** 'mouse-wheel-frame' specifies another frame whose windows shall be +scrolled instead. + ++++ +**** 'no-other-frame' has 'next-frame' and 'previous-frame' skip this +frame. + ++++ +**** 'skip-taskbar' removes a frame's icon from the taskbar and has +'Alt-<TAB>' skip this frame. + ++++ +**** 'no-focus-on-map' avoids that a frame gets input focus when mapped. + ++++ +**** 'no-accept-focus' means that a frame does not want to get input +focus via the mouse. + ++++ +**** 'undecorated' removes the window manager decorations from a frame. + ++++ +**** 'override-redirect' tells the window manager to disregard this +frame. + ++++ +**** 'width' and 'height' allow to specify pixel values and ratios now. + ++++ +**** 'left' and 'top' allow to specify ratios now. + ++++ +**** 'keep-ratio' preserves size and position of child frames when their +parent frame is resized. + ++++ +**** 'no-special-glyphs' suppresses display of truncation and +continuation glyphs in a frame. + ++++ +**** 'auto-hide-function' and 'minibuffer-exit' handle auto hiding of +frames and exiting from minibuffer individually. + ++++ +**** 'fit-frame-to-buffer-margins' and 'fit-frame-to-buffer-sizes' +handle fitting a frame to its buffer individually. + ++++ +**** 'drag-internal-border', 'drag-with-header-line', +'drag-with-mode-line', 'snap-width', 'top-visible' and 'bottom-visible' +allow to drag and resize frames with the mouse. + ++++ +**** 'minibuffer' is now set to the default minibuffer window when +initially specified as nil and is not reset to nil when initially +specifying a minibuffer window. + +*** The new function 'frame-list-z-order' returns a list of all frames +in Z (stacking) order. + ++++ +*** The function 'x-focus-frame' optionally tries to not activate its +frame. + ++++ +*** The variable 'focus-follows-mouse' has a third meaningful value +'auto-raise' to indicate that the window manager automatically raises a +frame when the mouse pointer enters it. + ++++ +*** The new function 'frame-restack' puts a frame above or below +another on the display. + ++++ +*** The new face 'internal-border' specifies the background of a frame's +internal border. + ++++ +*** The NORECORD argument of 'select-window' now has a meaningful value +'mark-for-redisplay' which is like any other non-nil value but marks +WINDOW for redisplay. + ++++ +*** Support for side windows is now official. The display action +function 'display-buffer-in-side-window' will display its buffer in a +side window. Functions for toggling all side windows on a frame, +changing and reversing the layout of side windows and returning the +main (major non-side) window of a frame are provided. For details +consult the section "(elisp) Side Windows" in the ELisp manual. + ++++ +*** Support for atomic windows - rectangular compositions of windows +treated by 'split-window', 'delete-window' and 'delete-other-windows' +like a single live window - is now official. For details consult the +section "(elisp) Atomic Windows" in the ELisp manual. + ++++ +*** New 'display-buffer' alist entry 'window-parameters' allows to +assign window parameters to the window used for displaying the buffer. + ++++ +*** New function 'display-buffer-reuse-mode-window' is an action function +suitable for use in 'display-buffer-alist'. For example, to avoid +creating a new window when opening man pages when there's already one, +use + +(add-to-list 'display-buffer-alist + '("\\`\\*Man .*\\*\\'" . + (display-buffer-reuse-mode-window + (inhibit-same-window . nil) + (mode . Man-mode)))) + ++++ +*** New window parameter 'no-delete-other-windows' prevents that +its window gets deleted by 'delete-other-windows'. + ++++ +*** New window parameters 'mode-line-format' and 'header-line-format' +allow to override the buffer-local formats for this window. + ++++ +*** New command 'window-swap-states' swaps the states of two live +windows. + ++++ +*** New functions 'window-pixel-width-before-size-change' and +'window-pixel-height-before-size-change' support detecting which +window changed size when 'window-size-change-functions' are run. + ++++ +*** The new function 'window-lines-pixel-dimensions' returns the pixel +dimensions of a window's text lines. + ++++ +*** The new function 'window-largest-empty-rectangle' returns the +dimensions of the largest rectangular area not occupying any text in a +window's body. + ++++ +*** The semantics of 'mouse-autoselect-window' has changed slightly. +For details see the section "(elisp) Mouse Window Auto-selection" in +the ELisp manual. + +--- +*** 'select-frame-by-name' now may return a frame on another display +if it does not find a suitable one on the current display. + +--- +** 'tcl-auto-fill-mode' is now declared obsolete. Its functionality +can be replicated simply by setting 'comment-auto-fill-only-comments'. + +** New pcase pattern 'rx' to match against an rx-style regular expression. +For details, see the doc string of 'rx--pcase-macroexpander'. + +--- +** New functions to set region from secondary selection and vice versa. +The new functions 'secondary-selection-to-region' and +'secondary-selection-from-region' let you set the beginning and the +end of the region from those of the secondary selection and vice +versa. + +** New function 'lgstring-remove-glyph' can be used to modify a +gstring returned by the underlying layout engine (e.g. m17n-flt, +uniscribe). + + +* Changes in Emacs 26.1 on Non-Free Operating Systems + ++++ +** Intercepting hotkeys on Windows 7 and later now works better. +The new keyboard hooking code properly grabs system hotkeys such as +'Win-*' and 'Alt-TAB', in a way that Emacs can get at them before the +system. This makes the 'w32-register-hot-key' functionality work +again on all versions of MS-Windows starting with Windows 7. On +Windows NT and later you can now register any hotkey combination. (On +Windows 9X, the previous limitations, spelled out in the Emacs manual, +still apply.) + +--- +** 'convert-standard-filename' no longer mirrors slashes on MS-Windows. +Previously, on MS-Windows this function converted slash characters in +file names into backslashes. It no longer does that. If your Lisp +program used 'convert-standard-filename' to prepare file names to be +passed to subprocesses (which is not the recommended usage of that +function), you will now have to mirror slashes in your application +code. One possible way is this: + + (let ((start 0)) + (while (string-match "/" file-name start) + (aset file-name (match-beginning 0) ?\\) + (setq start (match-end 0)))) + +--- +** GUI sessions on MS-Windows now treat SIGINT like Posix platforms do. +The effect of delivering a Ctrl-C (SIGINT) signal to a GUI Emacs on +MS-Windows is now the same as on Posix platforms -- Emacs saves the +session and exits. In particular, this will happen if you start +emacs.exe from the Windows shell, then type Ctrl-C into that shell's +window. + +--- +** 'signal-process' supports SIGTRAP on Windows XP and later. +The 'kill' emulation on Windows now maps SIGTRAP to a call to the +'DebugBreakProcess' API. This causes the receiving process to break +execution and return control to the debugger. If no debugger is +attached to the receiving process, the call is typically ignored. +This is in contrast to the default action on POSIX Systems, where it +causes the receiving process to terminate with a core dump if no +debugger has been attached to it. + +--- +** 'set-mouse-position' and 'set-mouse-absolute-pixel-position' work +on macOS. + +--- +** Emacs can now be run as a GUI application from the command line on +macOS. + ++++ +** 'ns-appearance' and 'ns-transparent-titlebar' change the appearance +of frame decorations on macOS 10.9+. + +--- +** 'ns-use-thin-smoothing' enables thin font smoothing on macOS 10.8+. + +--- +** 'process-attributes' on Darwin systems now returns more information. + +--- +** Mousewheel and trackpad scrolling on macOS 10.7+ now behaves more +like the macOS default. The new variables 'ns-mwheel-line-height', +'ns-use-mwheel-acceleration' and 'ns-use-mwheel-momentum' can be used +to customize the behavior. + + +---------------------------------------------------------------------- +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 2f6802948dd..5c72809f2a1 100644 --- a/etc/PROBLEMS +++ b/etc/PROBLEMS @@ -557,7 +557,7 @@ and then choose /usr/bin/netkit-ftp. *** Dired is very slow. -This could happen if invocation of the 'df' program takes a long +This could happen if getting a file system's status takes a long time. Possible reasons for this include: - ClearCase mounted filesystems (VOBs) that sometimes make 'df' @@ -565,12 +565,8 @@ time. Possible reasons for this include: - slow automounters on some old versions of Unix; - - slow operation of some versions of 'df'. - -To work around the problem, you could either (a) set the variable -'directory-free-space-program' to nil, and thus prevent Emacs from -invoking 'df'; (b) use 'df' from the GNU Coreutils package; or -(c) use CVS, which is Free Software, instead of ClearCase. +To work around the problem, you could use Git or some other +free-software program, instead of ClearCase. *** ps-print commands fail to find prologue files ps-prin*.ps. diff --git a/etc/images/icons/hicolor/scalable/apps/emacs.ico b/etc/images/icons/hicolor/scalable/apps/emacs.ico Binary files differnew file mode 100644 index 00000000000..70591275217 --- /dev/null +++ b/etc/images/icons/hicolor/scalable/apps/emacs.ico diff --git a/etc/images/splash.bmp b/etc/images/splash.bmp Binary files differnew file mode 100644 index 00000000000..3ec4c276d53 --- /dev/null +++ b/etc/images/splash.bmp diff --git a/etc/refcards/ru-refcard.tex b/etc/refcards/ru-refcard.tex index 6019c348417..0c4cfbe88fd 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]{26} % version of Emacs this is for +\newcommand{\versionemacs}[0]{27} % version of Emacs this is for \newcommand{\cyear}[0]{2018} % copyright year \newcommand\shortcopyrightnotice[0]{\vskip 1ex plus 2 fill diff --git a/lib/fsusage.c b/lib/fsusage.c new file mode 100644 index 00000000000..6920f8530a1 --- /dev/null +++ b/lib/fsusage.c @@ -0,0 +1,287 @@ +/* fsusage.c -- return space usage of mounted file systems + + Copyright (C) 1991-1992, 1996, 1998-1999, 2002-2006, 2009-2018 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 "fsusage.h" + +#include <limits.h> +#include <sys/types.h> + +#if STAT_STATVFS || STAT_STATVFS64 /* POSIX 1003.1-2001 (and later) with XSI */ +# include <sys/statvfs.h> +#else +/* Don't include backward-compatibility files unless they're needed. + Eventually we'd like to remove all this cruft. */ +# include <fcntl.h> +# include <unistd.h> +# include <sys/stat.h> +#if HAVE_SYS_PARAM_H +# include <sys/param.h> +#endif +#if HAVE_SYS_MOUNT_H +# include <sys/mount.h> +#endif +#if HAVE_SYS_VFS_H +# include <sys/vfs.h> +#endif +# if HAVE_SYS_FS_S5PARAM_H /* Fujitsu UXP/V */ +# include <sys/fs/s5param.h> +# endif +# if HAVE_SYS_STATFS_H +# include <sys/statfs.h> +# endif +# if HAVE_DUSTAT_H /* AIX PS/2 */ +# include <sys/dustat.h> +# endif +#endif + +/* Many space usage primitives use all 1 bits to denote a value that is + not applicable or unknown. Propagate this information by returning + a uintmax_t value that is all 1 bits if X is all 1 bits, even if X + is unsigned and narrower than uintmax_t. */ +#define PROPAGATE_ALL_ONES(x) \ + ((sizeof (x) < sizeof (uintmax_t) \ + && (~ (x) == (sizeof (x) < sizeof (int) \ + ? - (1 << (sizeof (x) * CHAR_BIT)) \ + : 0))) \ + ? UINTMAX_MAX : (uintmax_t) (x)) + +/* Extract the top bit of X as an uintmax_t value. */ +#define EXTRACT_TOP_BIT(x) ((x) \ + & ((uintmax_t) 1 << (sizeof (x) * CHAR_BIT - 1))) + +/* If a value is negative, many space usage primitives store it into an + integer variable by assignment, even if the variable's type is unsigned. + So, if a space usage variable X's top bit is set, convert X to the + uintmax_t value V such that (- (uintmax_t) V) is the negative of + the original value. If X's top bit is clear, just yield X. + Use PROPAGATE_TOP_BIT if the original value might be negative; + otherwise, use PROPAGATE_ALL_ONES. */ +#define PROPAGATE_TOP_BIT(x) ((x) | ~ (EXTRACT_TOP_BIT (x) - 1)) + +#ifdef STAT_STATVFS +/* Return true if statvfs works. This is false for statvfs on systems + with GNU libc on Linux kernels before 2.6.36, which stats all + preceding entries in /proc/mounts; that makes df hang if even one + of the corresponding file systems is hard-mounted but not available. */ +# if ! (__linux__ && (__GLIBC__ || __UCLIBC__)) +/* The FRSIZE fallback is not required in this case. */ +# undef STAT_STATFS2_FRSIZE +static int statvfs_works (void) { return 1; } +# else +# include <string.h> /* for strverscmp */ +# include <sys/utsname.h> +# include <sys/statfs.h> +# define STAT_STATFS2_BSIZE 1 + +static int +statvfs_works (void) +{ + static int statvfs_works_cache = -1; + struct utsname name; + if (statvfs_works_cache < 0) + statvfs_works_cache = (uname (&name) == 0 + && 0 <= strverscmp (name.release, "2.6.36")); + return statvfs_works_cache; +} +# endif +#endif + + +/* Fill in the fields of FSP with information about space usage for + the file system on which FILE resides. + DISK is the device on which FILE is mounted, for space-getting + methods that need to know it. + Return 0 if successful, -1 if not. When returning -1, ensure that + ERRNO is either a system error value, or zero if DISK is NULL + on a system that requires a non-NULL value. */ +int +get_fs_usage (char const *file, char const *disk, struct fs_usage *fsp) +{ +#ifdef STAT_STATVFS /* POSIX, except pre-2.6.36 glibc/Linux */ + + if (statvfs_works ()) + { + struct statvfs vfsd; + + if (statvfs (file, &vfsd) < 0) + return -1; + + /* f_frsize isn't guaranteed to be supported. */ + fsp->fsu_blocksize = (vfsd.f_frsize + ? PROPAGATE_ALL_ONES (vfsd.f_frsize) + : PROPAGATE_ALL_ONES (vfsd.f_bsize)); + + fsp->fsu_blocks = PROPAGATE_ALL_ONES (vfsd.f_blocks); + fsp->fsu_bfree = PROPAGATE_ALL_ONES (vfsd.f_bfree); + fsp->fsu_bavail = PROPAGATE_TOP_BIT (vfsd.f_bavail); + fsp->fsu_bavail_top_bit_set = EXTRACT_TOP_BIT (vfsd.f_bavail) != 0; + fsp->fsu_files = PROPAGATE_ALL_ONES (vfsd.f_files); + fsp->fsu_ffree = PROPAGATE_ALL_ONES (vfsd.f_ffree); + return 0; + } + +#endif + +#if defined STAT_STATVFS64 /* AIX */ + + struct statvfs64 fsd; + + if (statvfs64 (file, &fsd) < 0) + return -1; + + /* f_frsize isn't guaranteed to be supported. */ + fsp->fsu_blocksize = (fsd.f_frsize + ? PROPAGATE_ALL_ONES (fsd.f_frsize) + : PROPAGATE_ALL_ONES (fsd.f_bsize)); + +#elif defined STAT_STATFS2_FS_DATA /* Ultrix */ + + struct fs_data fsd; + + if (statfs (file, &fsd) != 1) + return -1; + + fsp->fsu_blocksize = 1024; + fsp->fsu_blocks = PROPAGATE_ALL_ONES (fsd.fd_req.btot); + fsp->fsu_bfree = PROPAGATE_ALL_ONES (fsd.fd_req.bfree); + fsp->fsu_bavail = PROPAGATE_TOP_BIT (fsd.fd_req.bfreen); + fsp->fsu_bavail_top_bit_set = EXTRACT_TOP_BIT (fsd.fd_req.bfreen) != 0; + fsp->fsu_files = PROPAGATE_ALL_ONES (fsd.fd_req.gtot); + fsp->fsu_ffree = PROPAGATE_ALL_ONES (fsd.fd_req.gfree); + +#elif defined STAT_STATFS3_OSF1 /* OSF/1 */ + + struct statfs fsd; + + if (statfs (file, &fsd, sizeof (struct statfs)) != 0) + return -1; + + fsp->fsu_blocksize = PROPAGATE_ALL_ONES (fsd.f_fsize); + +#elif defined STAT_STATFS2_FRSIZE /* 2.6 < glibc/Linux < 2.6.36 */ + + struct statfs fsd; + + if (statfs (file, &fsd) < 0) + return -1; + + fsp->fsu_blocksize = PROPAGATE_ALL_ONES (fsd.f_frsize); + +#elif defined STAT_STATFS2_BSIZE /* glibc/Linux < 2.6, 4.3BSD, SunOS 4, \ + Mac OS X < 10.4, FreeBSD < 5.0, \ + NetBSD < 3.0, OpenBSD < 4.4 */ + + struct statfs fsd; + + if (statfs (file, &fsd) < 0) + return -1; + + fsp->fsu_blocksize = PROPAGATE_ALL_ONES (fsd.f_bsize); + +# ifdef STATFS_TRUNCATES_BLOCK_COUNTS + + /* In SunOS 4.1.2, 4.1.3, and 4.1.3_U1, the block counts in the + struct statfs are truncated to 2GB. These conditions detect that + truncation, presumably without botching the 4.1.1 case, in which + the values are not truncated. The correct counts are stored in + undocumented spare fields. */ + if (fsd.f_blocks == 0x7fffffff / fsd.f_bsize && fsd.f_spare[0] > 0) + { + fsd.f_blocks = fsd.f_spare[0]; + fsd.f_bfree = fsd.f_spare[1]; + fsd.f_bavail = fsd.f_spare[2]; + } +# endif /* STATFS_TRUNCATES_BLOCK_COUNTS */ + +#elif defined STAT_STATFS2_FSIZE /* 4.4BSD and older NetBSD */ + + struct statfs fsd; + + if (statfs (file, &fsd) < 0) + return -1; + + fsp->fsu_blocksize = PROPAGATE_ALL_ONES (fsd.f_fsize); + +#elif defined STAT_STATFS4 /* SVR3, Dynix, old Irix, old AIX, \ + Dolphin */ + +# if !_AIX && !defined _SEQUENT_ && !defined DOLPHIN +# define f_bavail f_bfree +# endif + + struct statfs fsd; + + if (statfs (file, &fsd, sizeof fsd, 0) < 0) + return -1; + + /* Empirically, the block counts on most SVR3 and SVR3-derived + systems seem to always be in terms of 512-byte blocks, + no matter what value f_bsize has. */ +# if _AIX || defined _CRAY + fsp->fsu_blocksize = PROPAGATE_ALL_ONES (fsd.f_bsize); +# else + fsp->fsu_blocksize = 512; +# endif + +#endif + +#if (defined STAT_STATVFS64 || defined STAT_STATFS3_OSF1 \ + || defined STAT_STATFS2_FRSIZE || defined STAT_STATFS2_BSIZE \ + || defined STAT_STATFS2_FSIZE || defined STAT_STATFS4) + + fsp->fsu_blocks = PROPAGATE_ALL_ONES (fsd.f_blocks); + fsp->fsu_bfree = PROPAGATE_ALL_ONES (fsd.f_bfree); + fsp->fsu_bavail = PROPAGATE_TOP_BIT (fsd.f_bavail); + fsp->fsu_bavail_top_bit_set = EXTRACT_TOP_BIT (fsd.f_bavail) != 0; + fsp->fsu_files = PROPAGATE_ALL_ONES (fsd.f_files); + fsp->fsu_ffree = PROPAGATE_ALL_ONES (fsd.f_ffree); + +#endif + + (void) disk; /* avoid argument-unused warning */ + return 0; +} + +#if defined _AIX && defined _I386 +/* AIX PS/2 does not supply statfs. */ + +int +statfs (char *file, struct statfs *fsb) +{ + struct stat stats; + struct dustat fsd; + + if (stat (file, &stats) != 0) + return -1; + if (dustat (stats.st_dev, 0, &fsd, sizeof (fsd))) + return -1; + fsb->f_type = 0; + fsb->f_bsize = fsd.du_bsize; + fsb->f_blocks = fsd.du_fsize - fsd.du_isize; + fsb->f_bfree = fsd.du_tfree; + fsb->f_bavail = fsd.du_tfree; + fsb->f_files = (fsd.du_isize - 2) * fsd.du_inopb; + fsb->f_ffree = fsd.du_tinode; + fsb->f_fsid.val[0] = fsd.du_site; + fsb->f_fsid.val[1] = fsd.du_pckno; + return 0; +} + +#endif /* _AIX && _I386 */ diff --git a/lib/fsusage.h b/lib/fsusage.h new file mode 100644 index 00000000000..65daa736765 --- /dev/null +++ b/lib/fsusage.h @@ -0,0 +1,40 @@ +/* fsusage.h -- declarations for file system space usage info + + Copyright (C) 1991-1992, 1997, 2003-2006, 2009-2018 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/>. */ + +/* Space usage statistics for a file system. Blocks are 512-byte. */ + +#if !defined FSUSAGE_H_ +# define FSUSAGE_H_ + +# include <stdint.h> +# include <stdbool.h> + +struct fs_usage +{ + uintmax_t fsu_blocksize; /* Size of a block. */ + uintmax_t fsu_blocks; /* Total blocks. */ + uintmax_t fsu_bfree; /* Free blocks available to superuser. */ + uintmax_t fsu_bavail; /* Free blocks available to non-superuser. */ + bool fsu_bavail_top_bit_set; /* 1 if fsu_bavail represents a value < 0. */ + uintmax_t fsu_files; /* Total file nodes. */ + uintmax_t fsu_ffree; /* Free file nodes. */ +}; + +int get_fs_usage (char const *file, char const *disk, struct fs_usage *fsp); + +#endif diff --git a/lib/gnulib.mk.in b/lib/gnulib.mk.in index ee9e6bd12e1..49f4d236e44 100644 --- a/lib/gnulib.mk.in +++ b/lib/gnulib.mk.in @@ -21,7 +21,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=close --avoid=dup --avoid=fchdir --avoid=fstat --avoid=malloc-posix --avoid=msvc-inval --avoid=msvc-nothrow --avoid=openat-die --avoid=opendir --avoid=raise --avoid=save-cwd --avoid=select --avoid=setenv --avoid=sigprocmask --avoid=stat --avoid=stdarg --avoid=stdbool --avoid=threadlib --avoid=tzset --avoid=unsetenv --avoid=utime --avoid=utime-h --gnu-make --makefile-name=gnulib.mk.in --conditional-dependencies --no-libtool --macro-prefix=gl --no-vc-files alloca-opt binary-io byteswap c-ctype c-strcase careadlinkat close-stream count-leading-zeros count-one-bits count-trailing-zeros crypto/md5 crypto/sha1 crypto/sha256 crypto/sha512 d-type diffseq dtoastr dtotimespec dup2 environ execinfo explicit_bzero faccessat fcntl fcntl-h fdatasync fdopendir filemode filevercmp flexmember fstatat fsync getloadavg getopt-gnu gettime gettimeofday gitlog-to-changelog ignore-value intprops largefile lstat manywarnings memrchr minmax mkostemp mktime nstrftime pipe2 pselect pthread_sigmask putenv qcopy-acl readlink readlinkat sig2str socklen stat-time std-gnu11 stdalign stddef stdio stpcpy strtoimax symlink sys_stat sys_time tempname time time_r time_rz timegm timer-time timespec-add timespec-sub unlocked-io update-copyright utimens vla warnings +# Reproduce by: gnulib-tool --import --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=close --avoid=dup --avoid=fchdir --avoid=fstat --avoid=malloc-posix --avoid=msvc-inval --avoid=msvc-nothrow --avoid=openat-die --avoid=opendir --avoid=raise --avoid=save-cwd --avoid=select --avoid=setenv --avoid=sigprocmask --avoid=stat --avoid=stdarg --avoid=stdbool --avoid=threadlib --avoid=tzset --avoid=unsetenv --avoid=utime --avoid=utime-h --gnu-make --makefile-name=gnulib.mk.in --conditional-dependencies --no-libtool --macro-prefix=gl --no-vc-files alloca-opt binary-io byteswap c-ctype c-strcase careadlinkat close-stream count-leading-zeros count-one-bits count-trailing-zeros crypto/md5 crypto/sha1 crypto/sha256 crypto/sha512 d-type diffseq dtoastr dtotimespec dup2 environ execinfo explicit_bzero faccessat fcntl fcntl-h fdatasync fdopendir filemode filevercmp flexmember fstatat fsusage fsync getloadavg getopt-gnu gettime gettimeofday gitlog-to-changelog ignore-value intprops largefile lstat manywarnings memrchr minmax mkostemp mktime nstrftime pipe2 pselect pthread_sigmask putenv qcopy-acl readlink readlinkat sig2str socklen stat-time std-gnu11 stdalign stddef stdio stpcpy strtoimax symlink sys_stat sys_time tempname time time_r time_rz timegm timer-time timespec-add timespec-sub unlocked-io update-copyright utimens vla warnings MOSTLYCLEANFILES += core *.stackdump @@ -540,6 +540,9 @@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INT32_MAX_LT_INTMAX_MAX = @INT32_MAX_LT_INTMAX_MAX@ INT64_MAX_EQ_LONG_MAX = @INT64_MAX_EQ_LONG_MAX@ +JSON_CFLAGS = @JSON_CFLAGS@ +JSON_LIBS = @JSON_LIBS@ +JSON_OBJ = @JSON_OBJ@ KQUEUE_CFLAGS = @KQUEUE_CFLAGS@ KQUEUE_LIBS = @KQUEUE_LIBS@ KRB4LIB = @KRB4LIB@ @@ -945,7 +948,6 @@ pdfdir = @pdfdir@ prefix = @prefix@ program_transform_name = @program_transform_name@ psdir = @psdir@ -runstatedir = @runstatedir@ sbindir = @sbindir@ sharedstatedir = @sharedstatedir@ srcdir = @srcdir@ @@ -1518,6 +1520,17 @@ EXTRA_libgnu_a_SOURCES += at-func.c fstatat.c endif ## end gnulib module fstatat +## begin gnulib module fsusage +ifeq (,$(OMIT_GNULIB_MODULE_fsusage)) + + +EXTRA_DIST += fsusage.c fsusage.h + +EXTRA_libgnu_a_SOURCES += fsusage.c + +endif +## end gnulib module fsusage + ## begin gnulib module fsync ifeq (,$(OMIT_GNULIB_MODULE_fsync)) diff --git a/lisp/allout-widgets.el b/lisp/allout-widgets.el index a53776d62a6..71b1b390089 100644 --- a/lisp/allout-widgets.el +++ b/lisp/allout-widgets.el @@ -768,8 +768,7 @@ Optional RECURSING is for internal use, to limit recursion." (if allout-widgets-time-decoration-activity (setq allout-widgets-last-decoration-timing - (list (allout-elapsed-time-seconds (current-time) - start-time) + (list (allout-elapsed-time-seconds nil start-time) allout-widgets-changes-record))) (setq allout-widgets-changes-record nil) diff --git a/lisp/allout.el b/lisp/allout.el index 77aa906ee6c..a0456d5bd26 100644 --- a/lisp/allout.el +++ b/lisp/allout.el @@ -1687,7 +1687,7 @@ from what it did before, for backwards compatibility. MODE is the activation mode - see `allout-auto-activation' for valid values." (declare (obsolete allout-auto-activation "23.3")) - (custom-set-variables (list 'allout-auto-activation (format "%s" mode))) + (customize-set-variable 'allout-auto-activation (format "%s" mode)) (format "%s" mode)) ;;;_ > allout-setup-menubar () diff --git a/lisp/ansi-color.el b/lisp/ansi-color.el index 87b15ba4d31..6fb7acf600f 100644 --- a/lisp/ansi-color.el +++ b/lisp/ansi-color.el @@ -182,7 +182,7 @@ in shell buffers. You set this variable by calling one of: :group 'ansi-colors :version "23.2") -(defvar ansi-color-apply-face-function 'ansi-color-apply-overlay-face +(defvar ansi-color-apply-face-function #'ansi-color-apply-overlay-face "Function for applying an Ansi Color face to text in a buffer. This function should accept three arguments: BEG, END, and FACE, and it should apply face FACE to the text between BEG and END.") @@ -480,6 +480,7 @@ Emacs requires OBJECT to be a buffer." ;; In order to avoid this, we use the `insert-behind-hooks' overlay ;; property to make sure it works. (let ((overlay (make-overlay from to object))) + (overlay-put overlay 'evaporate t) (overlay-put overlay 'modification-hooks '(ansi-color-freeze-overlay)) (overlay-put overlay 'insert-behind-hooks '(ansi-color-freeze-overlay)) overlay))) diff --git a/lisp/auth-source-pass.el b/lisp/auth-source-pass.el index d783b26b4e3..3e6a9cccbc4 100644 --- a/lisp/auth-source-pass.el +++ b/lisp/auth-source-pass.el @@ -139,11 +139,6 @@ CONTENTS is the contents of a password-store formatted file." (mapconcat #'identity (cdr pair) ":"))))) (cdr lines))))) -(defun auth-source-pass--user-match-p (entry user) - "Return true iff ENTRY match USER." - (or (null user) - (string= user (auth-source-pass-get "user" entry)))) - (defun auth-source-pass--hostname (host) "Extract hostname from HOST." (let ((url (url-generic-parse-url host))) @@ -159,6 +154,11 @@ CONTENTS is the contents of a password-store formatted file." (hostname hostname) (t host)))) +(defun auth-source-pass--user (host) + "Extract user from HOST and return it. +Return nil if no match was found." + (url-user (url-generic-parse-url host))) + (defun auth-source-pass--do-debug (&rest msg) "Call `auth-source-do-debug` with MSG and a prefix." (apply #'auth-source-do-debug @@ -235,14 +235,17 @@ matching USER." If many matches are found, return the first one. If no match is found, return nil." (or - (if (url-user (url-generic-parse-url host)) + (if (auth-source-pass--user host) ;; if HOST contains a user (e.g., "user@host.com"), <HOST> (auth-source-pass--find-one-by-entry-name (auth-source-pass--hostname-with-user host) user) ;; otherwise, if USER is provided, search for <USER>@<HOST> (when (stringp user) (auth-source-pass--find-one-by-entry-name (concat user "@" (auth-source-pass--hostname host)) user))) - ;; if that didn't work, search for HOST without it's user component if any + ;; if that didn't work, search for HOST without its user component, if any (auth-source-pass--find-one-by-entry-name (auth-source-pass--hostname host) user) + ;; if that didn't work, search for HOST with user extracted from it + (auth-source-pass--find-one-by-entry-name + (auth-source-pass--hostname host) (auth-source-pass--user host)) ;; if that didn't work, remove subdomain: foo.bar.com -> bar.com (let ((components (split-string host "\\."))) (when (= (length components) 3) diff --git a/lisp/auth-source.el b/lisp/auth-source.el index c605c112a51..8ef5f7140ac 100644 --- a/lisp/auth-source.el +++ b/lisp/auth-source.el @@ -39,6 +39,7 @@ ;;; Code: +(require 'json) (require 'password-cache) (eval-when-compile (require 'cl-lib)) @@ -379,24 +380,39 @@ soon as a function returns non-nil.") ;; take just a file name use it as a netrc/plist file ;; matching any user, host, and protocol (when (stringp entry) - (setq entry `(:source ,entry))) - (cond - ;; a file name with parameters - ((stringp (plist-get entry :source)) - (if (equal (file-name-extension (plist-get entry :source)) "plist") + (setq entry (list :source entry))) + (let* ((source (plist-get entry :source)) + (source-without-gpg + (if (and (stringp source) + (equal (file-name-extension source) "gpg")) + (file-name-sans-extension source) + (or source ""))) + (extension (or (and (stringp source-without-gpg) + (file-name-extension source-without-gpg)) + ""))) + (when (stringp source) + (cond + ((equal extension "plist") (auth-source-backend - (plist-get entry :source) - :source (plist-get entry :source) + source + :source source :type 'plstore :search-function #'auth-source-plstore-search :create-function #'auth-source-plstore-create - :data (plstore-open (plist-get entry :source))) - (auth-source-backend - (plist-get entry :source) - :source (plist-get entry :source) - :type 'netrc - :search-function #'auth-source-netrc-search - :create-function #'auth-source-netrc-create))))) + :data (plstore-open source))) + ((member-ignore-case extension '("json")) + (auth-source-backend + source + :source source + :type 'json + :search-function #'auth-source-json-search)) + (t + (auth-source-backend + source + :source source + :type 'netrc + :search-function #'auth-source-netrc-search + :create-function #'auth-source-netrc-create)))))) ;; Note this function should be last in the parser functions, so we add it first (add-hook 'auth-source-backend-parser-functions 'auth-source-backends-parser-file) @@ -1967,6 +1983,77 @@ entries for git.gnus.org: (plstore-get-file (oref backend data)))) (plstore-save (oref backend data))))) +;;; Backend specific parsing: JSON backend +;;; (auth-source-search :max 1 :machine "imap.gmail.com") +;;; (auth-source-search :max 1 :host '("my-gmail" "imap.gmail.com") :port '(993 "imaps" "imap" "993" "143") :user nil :require '(:user :secret)) + +(defun auth-source-json-check (host user port require item) + (and item + (auth-source-search-collection + (or host t) + (or + (plist-get item :machine) + (plist-get item :host) + t)) + (auth-source-search-collection + (or user t) + (or + (plist-get item :login) + (plist-get item :account) + (plist-get item :user) + t)) + (auth-source-search-collection + (or port t) + (or + (plist-get item :port) + (plist-get item :protocol) + t)) + (or + ;; the required list of keys is nil, or + (null require) + ;; every element of require is in + (cl-loop for req in require + always (plist-get item req))))) + +(cl-defun auth-source-json-search (&rest spec + &key backend require + type max host user port + &allow-other-keys) + "Given a property list SPEC, return search matches from the :backend. +See `auth-source-search' for details on SPEC." + ;; just in case, check that the type is correct (null or same as the backend) + (cl-assert (or (null type) (eq type (oref backend type))) + t "Invalid JSON search: %s %s") + + ;; Hide the secrets early to avoid accidental exposure. + (let* ((jdata + (mapcar (lambda (entry) + (let (ret) + (while entry + (let* ((item (pop entry)) + (k (auth-source--symbol-keyword (car item))) + (v (cdr item))) + (setq k (cond ((memq k '(:machine)) :host) + ((memq k '(:login :account)) :user) + ((memq k '(:protocol)) :port) + ((memq k '(:password)) :secret) + (t k))) + ;; send back the secret in a function (lexical binding) + (when (eq k :secret) + (setq v (let ((lexv v)) + (lambda () lexv)))) + (setq ret (plist-put ret k v)))) + ret)) + (json-read-file (oref backend source)))) + (max (or max 5000)) ; sanity check: default to stop at 5K + all) + (dolist (item jdata) + (when (and item + (> max (length all)) + (auth-source-json-check host user port require item)) + (push item all))) + (nreverse all))) + ;;; older API ;; (auth-source-user-or-password '("login" "password") "imap.myhost.com" t "tzz") diff --git a/lisp/autoinsert.el b/lisp/autoinsert.el index f2ca52b1a19..53586c54180 100644 --- a/lisp/autoinsert.el +++ b/lisp/autoinsert.el @@ -141,14 +141,14 @@ If this contains a %s, that will be replaced by the matching rule." " .\\\" You may distribute this file under the terms of the GNU Free .\\\" Documentation License. -.TH " (file-name-base) +.TH " (file-name-base (buffer-file-name)) " " (file-name-extension (buffer-file-name)) " " (format-time-string "%Y-%m-%d ") "\n.SH NAME\n" - (file-name-base) + (file-name-base (buffer-file-name)) " \\- " str "\n.SH SYNOPSIS -.B " (file-name-base) +.B " (file-name-base (buffer-file-name)) "\n" _ " @@ -211,7 +211,7 @@ If this contains a %s, that will be replaced by the matching rule." \(provide '" - (file-name-base) + (file-name-base (buffer-file-name)) ") \;;; " (file-name-nondirectory (buffer-file-name)) " ends here\n") (("\\.texi\\(nfo\\)?\\'" . "Texinfo file skeleton") @@ -219,7 +219,7 @@ If this contains a %s, that will be replaced by the matching rule." "\\input texinfo @c -*-texinfo-*- @c %**start of header @setfilename " - (file-name-base) ".info\n" + (file-name-base (buffer-file-name)) ".info\n" "@settitle " str " @c %**end of header @copying\n" diff --git a/lisp/bindings.el b/lisp/bindings.el index ac84add3617..8375bb9a7b7 100644 --- a/lisp/bindings.el +++ b/lisp/bindings.el @@ -699,7 +699,7 @@ okay. See `mode-line-format'.") buffer-file-format buffer-auto-save-file-format buffer-display-count buffer-display-time enable-multibyte-characters - buffer-file-coding-system)) + buffer-file-coding-system truncate-lines)) ;; We have base64, md5 and sha1 functions built in now. (provide 'base64) diff --git a/lisp/calendar/cal-dst.el b/lisp/calendar/cal-dst.el index 508ae2c995f..00a8e7498af 100644 --- a/lisp/calendar/cal-dst.el +++ b/lisp/calendar/cal-dst.el @@ -1,4 +1,4 @@ -;;; cal-dst.el --- calendar functions for daylight saving rules +;;; cal-dst.el --- calendar functions for daylight saving rules -*- lexical-binding:t -*- ;; Copyright (C) 1993-1996, 2001-2018 Free Software Foundation, Inc. @@ -220,29 +220,30 @@ The result has the proper form for `calendar-daylight-savings-starts'." '((calendar-gregorian-from-absolute (calendar-persian-to-absolute `(7 1 ,(- year 621)))))))) (prevday-sec (- -1 utc-diff)) ; last sec of previous local day - (year (1+ y)) new-rules) - ;; Scan through the next few years until only one rule remains. - (while (cdr candidate-rules) - (dolist (rule candidate-rules) - ;; The rule we return should give a Gregorian date, but here - ;; we require an absolute date. The following is for efficiency. - (setq date (cond ((eq (car rule) 'calendar-nth-named-day) - (eval (cons 'calendar-nth-named-absday (cdr rule)))) - ((eq (car rule) 'calendar-gregorian-from-absolute) - (eval (cadr rule))) - (t (calendar-absolute-from-gregorian (eval rule))))) - (or (equal (current-time-zone - (calendar-time-from-absolute date prevday-sec)) - (current-time-zone - (calendar-time-from-absolute (1+ date) prevday-sec))) - (setq new-rules (cons rule new-rules)))) - ;; If no rules remain, just use the first candidate rule; - ;; it's wrong in general, but it's right for at least one year. - (setq candidate-rules (if new-rules (nreverse new-rules) - (list (car candidate-rules))) - new-rules nil - year (1+ year))) + (calendar-dlet* ((year (1+ y))) + ;; Scan through the next few years until only one rule remains. + (while (cdr candidate-rules) + (dolist (rule candidate-rules) + ;; The rule we return should give a Gregorian date, but here + ;; we require an absolute date. The following is for efficiency. + (setq date (cond ((eq (car rule) #'calendar-nth-named-day) + (eval (cons #'calendar-nth-named-absday + (cdr rule)))) + ((eq (car rule) #'calendar-gregorian-from-absolute) + (eval (cadr rule))) + (t (calendar-absolute-from-gregorian (eval rule))))) + (or (equal (current-time-zone + (calendar-time-from-absolute date prevday-sec)) + (current-time-zone + (calendar-time-from-absolute (1+ date) prevday-sec))) + (setq new-rules (cons rule new-rules)))) + ;; If no rules remain, just use the first candidate rule; + ;; it's wrong in general, but it's right for at least one year. + (setq candidate-rules (if new-rules (nreverse new-rules) + (list (car candidate-rules))) + new-rules nil + year (1+ year)))) (car candidate-rules))) ;; TODO it might be better to extract this information directly from @@ -279,14 +280,11 @@ for `calendar-current-time-zone'." (car t2-date-sec) t1-utc-diff)) (t1-time (/ (cdr t1-date-sec) 60)) (t2-time (/ (cdr t2-date-sec) 60))) - (cons - (/ (min t0-utc-diff t1-utc-diff) 60) - (cons - (/ (abs (- t0-utc-diff t1-utc-diff)) 60) - (if (< t0-utc-diff t1-utc-diff) - (list t0-name t1-name t1-rules t2-rules t1-time t2-time) - (list t1-name t0-name t2-rules t1-rules t2-time t1-time) - ))))))))) + (if (nth 7 (decode-time t1)) + (list (/ t0-utc-diff 60) (/ (- t1-utc-diff t0-utc-diff) 60) + t0-name t1-name t1-rules t2-rules t1-time t2-time) + (list (/ t1-utc-diff 60) (/ (- t0-utc-diff t1-utc-diff) 60) + t1-name t0-name t2-rules t1-rules t2-time t1-time)))))))) (defvar calendar-dst-transition-cache nil "Internal cal-dst variable storing date of daylight saving time transitions. @@ -405,7 +403,8 @@ This function respects the value of `calendar-dst-check-each-year-flag'." (or (let ((expr (if calendar-dst-check-each-year-flag (cadr (calendar-dst-find-startend year)) (nth 4 calendar-current-time-zone-cache)))) - (if expr (eval expr))) + (calendar-dlet* ((year year)) + (if expr (eval expr)))) ;; New US rules commencing 2007. https://www.iana.org/time-zones (and (not (zerop calendar-daylight-time-offset)) (calendar-nth-named-day 2 0 3 year)))) @@ -416,7 +415,8 @@ This function respects the value of `calendar-dst-check-each-year-flag'." (or (let ((expr (if calendar-dst-check-each-year-flag (nth 2 (calendar-dst-find-startend year)) (nth 5 calendar-current-time-zone-cache)))) - (if expr (eval expr))) + (calendar-dlet* ((year year)) + (if expr (eval expr)))) ;; New US rules commencing 2007. https://www.iana.org/time-zones (and (not (zerop calendar-daylight-time-offset)) (calendar-nth-named-day 1 0 11 year)))) @@ -425,25 +425,25 @@ This function respects the value of `calendar-dst-check-each-year-flag'." (defun dst-in-effect (date) "True if on absolute DATE daylight saving time is in effect. Fractional part of DATE is local standard time of day." - (let* ((year (calendar-extract-year - (calendar-gregorian-from-absolute (floor date)))) - (dst-starts-gregorian (eval calendar-daylight-savings-starts)) - (dst-ends-gregorian (eval calendar-daylight-savings-ends)) - (dst-starts (and dst-starts-gregorian + (calendar-dlet* ((year (calendar-extract-year + (calendar-gregorian-from-absolute (floor date))))) + (let* ((dst-starts-gregorian (eval calendar-daylight-savings-starts)) + (dst-ends-gregorian (eval calendar-daylight-savings-ends)) + (dst-starts (and dst-starts-gregorian + (+ (calendar-absolute-from-gregorian + dst-starts-gregorian) + (/ calendar-daylight-savings-starts-time + 60.0 24.0)))) + (dst-ends (and dst-ends-gregorian (+ (calendar-absolute-from-gregorian - dst-starts-gregorian) - (/ calendar-daylight-savings-starts-time - 60.0 24.0)))) - (dst-ends (and dst-ends-gregorian - (+ (calendar-absolute-from-gregorian - dst-ends-gregorian) - (/ (- calendar-daylight-savings-ends-time - calendar-daylight-time-offset) - 60.0 24.0))))) - (and dst-starts dst-ends - (if (< dst-starts dst-ends) - (and (<= dst-starts date) (< date dst-ends)) - (or (<= dst-starts date) (< date dst-ends)))))) + dst-ends-gregorian) + (/ (- calendar-daylight-savings-ends-time + calendar-daylight-time-offset) + 60.0 24.0))))) + (and dst-starts dst-ends + (if (< dst-starts dst-ends) + (and (<= dst-starts date) (< date dst-ends)) + (or (<= dst-starts date) (< date dst-ends))))))) ;; used by calc, lunar, solar. (defun dst-adjust-time (date time) diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el index dae7b9dc005..97acfab326b 100644 --- a/lisp/calendar/calendar.el +++ b/lisp/calendar/calendar.el @@ -115,6 +115,37 @@ (load "cal-loaddefs" nil t) +;; Calendar has historically relied heavily on dynamic scoping. +;; Concretely, this manifests in the use of references to let-bound variables +;; in Custom vars as well as code in diary files. +;; `eval` is hence the core of the culprit. It's used on: +;; - calendar-date-display-form +;; - calendar-time-display-form +;; - calendar-chinese-time-zone +;; - in cal-dst's there are various calls to `eval' but they seem not to refer +;; to let-bound variables, surprisingly. +;; - calendar-date-echo-text +;; - calendar-mode-line-format +;; - cal-tex-daily-string +;; - diary-date-forms +;; - diary-remind-message +;; - calendar-holidays +;; - calendar-location-name +;; - whatever is passed to calendar-string-spread +;; - whatever is passed to calendar-insert-at-column +;; - whatever is passed to diary-sexp-entry +;; - whatever is passed to diary-remind + +(defmacro calendar-dlet* (binders &rest body) + "Like `let*' but using dynamic scoping." + (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))) + ;; Avoid recursive load of calendar when loading cal-menu. Yuck. (provide 'calendar) (require 'cal-menu) diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el index 9f2a3334efd..159dd9ba3d1 100644 --- a/lisp/calendar/diary-lib.el +++ b/lisp/calendar/diary-lib.el @@ -1,4 +1,4 @@ -;;; diary-lib.el --- diary functions +;;; diary-lib.el --- diary functions -*- lexical-binding:t -*- ;; Copyright (C) 1989-1990, 1992-1995, 2001-2018 Free Software ;; Foundation, Inc. @@ -119,7 +119,7 @@ are: `string', `symbol', `int', `tnil', `stringtnil.'" :type 'boolean :group 'diary) -(defcustom diary-file-name-prefix-function 'identity +(defcustom diary-file-name-prefix-function #'identity "The function that will take a diary file name and return the desired prefix." :type 'function :group 'diary) @@ -156,7 +156,7 @@ Used for example by the appointment package - see `appt-activate'." :type 'hook :group 'diary) -(defcustom diary-display-function 'diary-fancy-display +(defcustom diary-display-function #'diary-fancy-display "Function used to display the diary. The two standard options are `diary-fancy-display' and `diary-simple-display'. @@ -185,9 +185,9 @@ diary buffer to be displayed with diary entries from various included files, each day's entries sorted into lexicographic order, add the following to your init file: - (setq diary-display-function \\='diary-fancy-display) - (add-hook \\='diary-list-entries-hook \\='diary-include-other-diary-files) - (add-hook \\='diary-list-entries-hook \\='diary-sort-entries t) + (setq diary-display-function #\\='diary-fancy-display) + (add-hook \\='diary-list-entries-hook #\\='diary-include-other-diary-files) + (add-hook \\='diary-list-entries-hook #\\='diary-sort-entries t) Note how the sort function is placed last, so that it can sort the entries included from other files. @@ -251,7 +251,7 @@ use `diary-mark-entries-hook', which runs only for the main diary file." diary-islamic-mark-entries) :group 'diary) -(defcustom diary-print-entries-hook 'lpr-buffer +(defcustom diary-print-entries-hook #'lpr-buffer "Run by `diary-print-entries' after preparing a temporary diary buffer. The buffer shows only the diary entries currently visible in the diary buffer. The default just does the printing. Other uses @@ -328,7 +328,8 @@ Returns a string using match elements 1-5, where: ;; use the standard function calendar-date-string. (concat (if month (calendar-date-string (list month (string-to-number day) - (string-to-number year)) nil t) + (string-to-number year)) + nil t) (cond ((eq calendar-date-style 'iso) "\\3 \\1 \\2") ; YMD ((eq calendar-date-style 'european) "\\2 \\1 \\3") ; DMY (t "\\1 \\2 \\3"))) ; MDY @@ -552,42 +553,40 @@ If ENTRY is a string, search for matches in that string, and remove them. Returns a list of ENTRY followed by (ATTRIBUTE VALUE) pairs. When ENTRY is non-nil, FILEGLOBATTRS forms the start of the (ATTRIBUTE VALUE) pairs." - (let (regexp regnum attrname attrname attrvalue type ret-attr) + (let (ret-attr) (if (null entry) (save-excursion (dolist (attr diary-face-attrs) ;; FIXME inefficient searching. (goto-char (point-min)) - (setq regexp (concat diary-glob-file-regexp-prefix (car attr)) - regnum (cadr attr) - attrname (nth 2 attr) - type (nth 3 attr) - attrvalue (if (re-search-forward regexp nil t) - (match-string-no-properties regnum))) - (and attrvalue - (setq attrvalue (diary-attrtype-convert attrvalue type)) - (setq ret-attr (append ret-attr - (list attrname attrvalue)))))) + (let* ((regexp (concat diary-glob-file-regexp-prefix (car attr))) + (regnum (cadr attr)) + (attrname (nth 2 attr)) + (type (nth 3 attr)) + (attrvalue (if (re-search-forward regexp nil t) + (match-string-no-properties regnum)))) + (and attrvalue + (setq attrvalue (diary-attrtype-convert attrvalue type)) + (setq ret-attr (append ret-attr + (list attrname attrvalue))))))) (setq ret-attr fileglobattrs) (dolist (attr diary-face-attrs) - (setq regexp (car attr) - regnum (cadr attr) - attrname (nth 2 attr) - type (nth 3 attr) - attrvalue nil) - ;; If multiple matches, replace all, use the last (which may - ;; be the first instance in the line, if the regexp is - ;; anchored with $). - (while (string-match regexp entry) - (setq attrvalue (match-string-no-properties regnum entry) - entry (replace-match "" t t entry))) - (and attrvalue - (setq attrvalue (diary-attrtype-convert attrvalue type)) - (setq ret-attr (append ret-attr (list attrname attrvalue)))))) + (let ((regexp (car attr)) + (regnum (cadr attr)) + (attrname (nth 2 attr)) + (type (nth 3 attr)) + (attrvalue nil)) + ;; If multiple matches, replace all, use the last (which may + ;; be the first instance in the line, if the regexp is + ;; anchored with $). + (while (string-match regexp entry) + (setq attrvalue (match-string-no-properties regnum entry) + entry (replace-match "" t t entry))) + (and attrvalue + (setq attrvalue (diary-attrtype-convert attrvalue type)) + (setq ret-attr (append ret-attr (list attrname attrvalue))))))) (list entry ret-attr))) - - (defvar diary-modify-entry-list-string-function nil "Function applied to entry string before putting it into the entries list. Can be used by programs integrating a diary list into other buffers (e.g. @@ -656,9 +655,12 @@ any entries were found." (let* ((month (calendar-extract-month date)) (day (calendar-extract-day date)) (year (calendar-extract-year date)) - (dayname (format "%s\\|%s\\.?" (calendar-day-name date) - (calendar-day-name date 'abbrev))) (calendar-month-name-array (or months calendar-month-name-array)) + (case-fold-search t) + entry-found) + (calendar-dlet* + ((dayname (format "%s\\|%s\\.?" (calendar-day-name date) + (calendar-day-name date 'abbrev))) (monthname (format "\\*\\|%s%s" (calendar-month-name month) (if months "" (format "\\|%s\\.?" @@ -668,61 +670,60 @@ any entries were found." (year (format "\\*\\|0*%d%s" year (if diary-abbreviated-year-flag (format "\\|%02d" (% year 100)) - ""))) - (case-fold-search t) - entry-found) - (dolist (date-form diary-date-forms) - (let ((backup (when (eq (car date-form) 'backup) - (setq date-form (cdr date-form)) - t)) - ;; date-form uses day etc as set above. - (regexp (format "^%s?%s\\(%s\\)" (regexp-quote mark) - (if symbol (regexp-quote symbol) "") - (mapconcat 'eval date-form "\\)\\(?:"))) - entry-start date-start temp) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (if backup (re-search-backward "\\<" nil t)) - ;; regexp moves us past the end of date, onto the next line. - ;; Trailing whitespace after date not allowed (see diary-file). - (if (and (bolp) (not (looking-at "[ \t]"))) - ;; Diary entry that consists only of date. - (backward-char 1) - ;; Found a nonempty diary entry--make it - ;; visible and add it to the list. - (setq date-start (line-end-position 0)) - ;; Actual entry starts on the next-line? - (if (looking-at "[ \t]*\n[ \t]") (forward-line 1)) - (setq entry-found t - entry-start (point)) - (forward-line 1) - (while (looking-at "[ \t]") ; continued entry - (forward-line 1)) - (unless (and (eobp) (not (bolp))) - (backward-char 1)) - (unless list-only - (remove-overlays date-start (point) 'invisible 'diary)) - (setq temp (diary-pull-attrs - (buffer-substring-no-properties - entry-start (point)) globattr)) - (diary-add-to-list - (or gdate date) (car temp) - (buffer-substring-no-properties (1+ date-start) (1- entry-start)) - (copy-marker entry-start) (cadr temp)))))) - entry-found)) + "")))) + (dolist (date-form diary-date-forms) + (let ((backup (when (eq (car date-form) 'backup) + (setq date-form (cdr date-form)) + t)) + ;; date-form uses day etc as set above. + (regexp (format "^%s?%s\\(%s\\)" (regexp-quote mark) + (if symbol (regexp-quote symbol) "") + (mapconcat #'eval date-form "\\)\\(?:"))) + entry-start date-start temp) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (if backup (re-search-backward "\\<" nil t)) + ;; regexp moves us past the end of date, onto the next line. + ;; Trailing whitespace after date not allowed (see diary-file). + (if (and (bolp) (not (looking-at "[ \t]"))) + ;; Diary entry that consists only of date. + (backward-char 1) + ;; Found a nonempty diary entry--make it + ;; visible and add it to the list. + (setq date-start (line-end-position 0)) + ;; Actual entry starts on the next-line? + (if (looking-at "[ \t]*\n[ \t]") (forward-line 1)) + (setq entry-found t + entry-start (point)) + (forward-line 1) + (while (looking-at "[ \t]") ; continued entry + (forward-line 1)) + (unless (and (eobp) (not (bolp))) + (backward-char 1)) + (unless list-only + (remove-overlays date-start (point) 'invisible 'diary)) + (setq temp (diary-pull-attrs + (buffer-substring-no-properties + entry-start (point)) + globattr)) + (diary-add-to-list + (or gdate date) (car temp) + (buffer-substring-no-properties + (1+ date-start) (1- entry-start)) + (copy-marker entry-start) (cadr temp)))))) + entry-found))) (defvar original-date) ; from diary-list-entries (defvar file-glob-attrs) -(defvar list-only) -(defvar number) (defun diary-list-entries-1 (months symbol absfunc) "List diary entries of a certain type. MONTHS is an array of month names. SYMBOL marks diary entries of the type in question. ABSFUNC is a function that converts absolute dates to dates of the appropriate type." + (with-no-warnings (defvar number) (defvar list-only)) (let ((gdate original-date)) - (dotimes (_idummy number) + (dotimes (_ number) (diary-list-entries-2 (funcall absfunc (calendar-absolute-from-gregorian gdate)) diary-nonmarking-symbol file-glob-attrs list-only months symbol gdate) @@ -735,6 +736,10 @@ of the appropriate type." "List of any diary files included in the last call to `diary-list-entries'. Or to `diary-mark-entries'.") +(defvar diary-saved-point) ; bound in diary-list-entries +(defvar diary-including) +(defvar date-string) ; bound in diary-list-entries + (defun diary-list-entries (date number &optional list-only) "Create and display a buffer containing the relevant lines in `diary-file'. Selects entries for NUMBER days starting with date DATE. Hides any @@ -832,7 +837,7 @@ LIST-ONLY is non-nil, in which case it just returns the list." (set (make-local-variable 'diary-selective-display) t) (overlay-put ol 'invisible 'diary) (overlay-put ol 'evaporate t))) - (dotimes (_idummy number) + (dotimes (_ number) (let ((sexp-found (diary-list-sexp-entries date)) (entry-found (diary-list-entries-2 date diary-nonmarking-symbol @@ -848,8 +853,10 @@ LIST-ONLY is non-nil, in which case it just returns the list." ;; every time, diary-include-other-diary-files ;; binds it to nil (essentially) when it runs ;; in included files. - (run-hooks 'diary-nongregorian-listing-hook - 'diary-list-entries-hook) + (calendar-dlet* ((number number) + (list-only list-only)) + (run-hooks 'diary-nongregorian-listing-hook + 'diary-list-entries-hook)) ;; We could make this explicit: ;;; (run-hooks 'diary-nongregorian-listing-hook) ;;; (if d-incp @@ -878,8 +885,6 @@ LIST-ONLY is non-nil, in which case it just returns the list." (remove-overlays (point-min) (point-max) 'invisible 'diary)) (kill-local-variable 'mode-line-format)) -(defvar original-date) ; bound in diary-list-entries -;(defvar number) ; already declared above (defun diary-include-files (&optional mark) "Process diary entries from included diary files. @@ -894,8 +899,8 @@ This is recursive; that is, included files may include other files." (format "^%s \"\\([^\"]*\\)\"" (regexp-quote diary-include-string)) nil t) (let ((diary-file (match-string-no-properties 1)) - (diary-mark-entries-hook 'diary-mark-included-diary-files) - (diary-list-entries-hook 'diary-include-other-diary-files) + (diary-mark-entries-hook #'diary-mark-included-diary-files) + (diary-list-entries-hook #'diary-include-other-diary-files) (diary-including t) diary-hook diary-list-include-blanks efile) (if (file-exists-p diary-file) @@ -907,6 +912,13 @@ This is recursive; that is, included files may include other files." (append diary-included-files (list efile))) (if mark (diary-mark-entries) + ;; FIXME: `diary-include-files' can be run from + ;; diary-mark-entries-hook (via + ;; diary-mark-included-diary-files) or from + ;; diary-list-entries-hook (via + ;; diary-include-other-diary-files). In the "list" case, + ;; `number' is dynamically bound, but not in the "mark" case! + (with-no-warnings (defvar number)) (setq diary-entries-list (append diary-entries-list (diary-list-entries original-date number t))))) @@ -929,8 +941,6 @@ For details, see `diary-include-files'. See also `diary-mark-included-diary-files'." (diary-include-files)) -(defvar date-string) ; bound in diary-list-entries - (defun diary-display-no-entries () "Common subroutine of `diary-simple-display' and `diary-fancy-display'. Handles the case where there are no diary entries. @@ -940,7 +950,7 @@ Returns a cons (NOENTRIES . HOLIDAY-STRING)." (hol-string (format "%s%s%s" date-string (if holiday-list ": " "") - (mapconcat 'identity holiday-list "; "))) + (mapconcat #'identity holiday-list "; "))) (msg (format "No diary entries for %s" hol-string)) ;; Empty list, or single item with no text. ;; FIXME multiple items with no text? @@ -957,13 +967,11 @@ Returns a cons (NOENTRIES . HOLIDAY-STRING)." ;; holiday-list which is too wide for a message gets a buffer. (calendar-in-read-only-buffer holiday-buffer (calendar-set-mode-line (format "Holidays for %s" date-string)) - (insert (mapconcat 'identity holiday-list "\n"))) + (insert (mapconcat #'identity holiday-list "\n"))) (message "No diary entries for %s" date-string))) (cons noentries hol-string))) -(defvar diary-saved-point) ; bound in diary-list-entries - (defun diary-simple-display () "Display the diary buffer if there are any relevant entries or holidays. Entries that do not apply are made invisible. Holidays are shown @@ -987,7 +995,7 @@ in the mode line. This is an option for `diary-display-function'." (set-window-point window diary-saved-point) (set-window-start window (point-min))))))) -(defvar diary-goto-entry-function 'diary-goto-entry +(defvar diary-goto-entry-function #'diary-goto-entry "Function called to jump to a diary entry. Modes that require special handling of the included file containing the diary entry can assign a suitable function to this @@ -1022,6 +1030,9 @@ variable.") (goto-char (match-beginning 1))))) (message "Unable to locate this diary entry"))))) +(defvar displayed-year) ; bound in calendar-generate +(defvar displayed-month) + (defun diary-fancy-display () "Prepare a diary buffer with relevant entries in a fancy, noneditable form. Holidays are shown unless `diary-show-holidays-flag' is nil. @@ -1204,7 +1215,7 @@ ensure that all relevant variables are set. (interactive "P") (if (string-equal diary-mail-addr "") (user-error "You must set `diary-mail-addr' to use this command") - (let ((diary-display-function 'diary-fancy-display)) + (let ((diary-display-function #'diary-fancy-display)) (diary-list-entries (calendar-current-date) (or ndays diary-mail-days))) (compose-mail diary-mail-addr (concat "Diary entries generated " @@ -1242,109 +1253,111 @@ MARKFUNC is a function that marks entries of the appropriate type matching a given date pattern. MONTHS is an array of month names. SYMBOL marks diary entries of the type in question. ABSFUNC is a function that converts absolute dates to dates of the appropriate type. " - (let ((dayname (diary-name-pattern calendar-day-name-array - calendar-day-abbrev-array)) - (monthname (format "%s\\|\\*" - (if months - (diary-name-pattern months) - (diary-name-pattern calendar-month-name-array - calendar-month-abbrev-array)))) - (month "[0-9]+\\|\\*") - (day "[0-9]+\\|\\*") - (year "[0-9]+\\|\\*") - (case-fold-search t) - marks) - (dolist (date-form diary-date-forms) - (if (eq (car date-form) 'backup) ; ignore 'backup directive - (setq date-form (cdr date-form))) - (let* ((l (length date-form)) - (d-name-pos (- l (length (memq 'dayname date-form)))) - (d-name-pos (if (/= l d-name-pos) (1+ d-name-pos))) - (m-name-pos (- l (length (memq 'monthname date-form)))) - (m-name-pos (if (/= l m-name-pos) (1+ m-name-pos))) - (d-pos (- l (length (memq 'day date-form)))) - (d-pos (if (/= l d-pos) (1+ d-pos))) - (m-pos (- l (length (memq 'month date-form)))) - (m-pos (if (/= l m-pos) (1+ m-pos))) - (y-pos (- l (length (memq 'year date-form)))) - (y-pos (if (/= l y-pos) (1+ y-pos))) - (regexp (format "^%s\\(%s\\)" - (if symbol (regexp-quote symbol) "") - (mapconcat 'eval date-form "\\)\\(")))) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (let* ((dd-name - (if d-name-pos - (match-string-no-properties d-name-pos))) - (mm-name - (if m-name-pos - (match-string-no-properties m-name-pos))) - (mm (string-to-number - (if m-pos - (match-string-no-properties m-pos) - ""))) - (dd (string-to-number - (if d-pos - (match-string-no-properties d-pos) - ""))) - (y-str (if y-pos - (match-string-no-properties y-pos))) - (yy (if (not y-str) - 0 - (if (and (= (length y-str) 2) - diary-abbreviated-year-flag) - (let* ((current-y - (calendar-extract-year - (if absfunc - (funcall - absfunc - (calendar-absolute-from-gregorian - (calendar-current-date))) - (calendar-current-date)))) - (y (+ (string-to-number y-str) - ;; Current century, eg 2000. - (* 100 (/ current-y 100)))) - (offset (- y current-y))) - ;; Add 2-digit year to current century. - ;; If more than 50 years in the future, - ;; assume last century. If more than 50 - ;; years in the past, assume next century. - (if (> offset 50) - (- y 100) - (if (< offset -50) - (+ y 100) - y))) - (string-to-number y-str))))) - (setq marks (cadr (diary-pull-attrs - (buffer-substring-no-properties - (point) (line-end-position)) - file-glob-attrs))) - ;; Only mark all days of a given name if the pattern - ;; contains no more specific elements. - (if (and dd-name (not (or d-pos m-pos y-pos))) - (calendar-mark-days-named - (cdr (assoc-string dd-name + (calendar-dlet* + ((dayname (diary-name-pattern calendar-day-name-array + calendar-day-abbrev-array)) + (monthname (format "%s\\|\\*" + (if months + (diary-name-pattern months) + (diary-name-pattern calendar-month-name-array + calendar-month-abbrev-array)))) + (month "[0-9]+\\|\\*") + (day "[0-9]+\\|\\*") + (year "[0-9]+\\|\\*")) + (let* ((case-fold-search t) + marks) + (dolist (date-form diary-date-forms) + (if (eq (car date-form) 'backup) ; ignore 'backup directive + (setq date-form (cdr date-form))) + (let* ((l (length date-form)) + (d-name-pos (- l (length (memq 'dayname date-form)))) + (d-name-pos (if (/= l d-name-pos) (1+ d-name-pos))) + (m-name-pos (- l (length (memq 'monthname date-form)))) + (m-name-pos (if (/= l m-name-pos) (1+ m-name-pos))) + (d-pos (- l (length (memq 'day date-form)))) + (d-pos (if (/= l d-pos) (1+ d-pos))) + (m-pos (- l (length (memq 'month date-form)))) + (m-pos (if (/= l m-pos) (1+ m-pos))) + (y-pos (- l (length (memq 'year date-form)))) + (y-pos (if (/= l y-pos) (1+ y-pos))) + (regexp (format "^%s\\(%s\\)" + (if symbol (regexp-quote symbol) "") + (mapconcat #'eval date-form "\\)\\(")))) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (let* ((dd-name + (if d-name-pos + (match-string-no-properties d-name-pos))) + (mm-name + (if m-name-pos + (match-string-no-properties m-name-pos))) + (mm (string-to-number + (if m-pos + (match-string-no-properties m-pos) + ""))) + (dd (string-to-number + (if d-pos + (match-string-no-properties d-pos) + ""))) + (y-str (if y-pos + (match-string-no-properties y-pos))) + (yy (if (not y-str) + 0 + (if (and (= (length y-str) 2) + diary-abbreviated-year-flag) + (let* ((current-y + (calendar-extract-year + (if absfunc + (funcall + absfunc + (calendar-absolute-from-gregorian + (calendar-current-date))) + (calendar-current-date)))) + (y (+ (string-to-number y-str) + ;; Current century, eg 2000. + (* 100 (/ current-y 100)))) + (offset (- y current-y))) + ;; Add 2-digit year to current century. + ;; If more than 50 years in the future, + ;; assume last century. If more than 50 + ;; years in the past, assume next century. + (if (> offset 50) + (- y 100) + (if (< offset -50) + (+ y 100) + y))) + (string-to-number y-str))))) + (setq marks (cadr (diary-pull-attrs + (buffer-substring-no-properties + (point) (line-end-position)) + file-glob-attrs))) + ;; Only mark all days of a given name if the pattern + ;; contains no more specific elements. + (if (and dd-name (not (or d-pos m-pos y-pos))) + (calendar-mark-days-named + (cdr (assoc-string dd-name + (calendar-make-alist + calendar-day-name-array + 0 nil calendar-day-abbrev-array + (mapcar (lambda (e) + (format "%s." e)) + calendar-day-abbrev-array)) + t)) + marks) + (if mm-name + (setq mm + (if (string-equal mm-name "*") 0 + (cdr (assoc-string + mm-name + (if months (calendar-make-alist months) (calendar-make-alist - calendar-day-name-array - 0 nil calendar-day-abbrev-array + calendar-month-name-array + 1 nil calendar-month-abbrev-array (mapcar (lambda (e) (format "%s." e)) - calendar-day-abbrev-array)) - t)) marks) - (if mm-name - (setq mm - (if (string-equal mm-name "*") 0 - (cdr (assoc-string - mm-name - (if months (calendar-make-alist months) - (calendar-make-alist - calendar-month-name-array - 1 nil calendar-month-abbrev-array - (mapcar (lambda (e) - (format "%s." e)) - calendar-month-abbrev-array))) - t))))) - (funcall markfunc mm dd yy marks)))))))) + calendar-month-abbrev-array))) + t))))) + (funcall markfunc mm dd yy marks))))))))) ;;;###cal-autoload (defun diary-mark-entries (&optional redraw) @@ -1406,30 +1419,30 @@ marks. This is intended to deal with deleted diary entries." (defun diary-sexp-entry (sexp entry date) "Process a SEXP diary ENTRY for DATE." - (let ((result (if calendar-debug-sexp - (let ((debug-on-error t)) - (eval (car (read-from-string sexp)))) - (let (err) - (condition-case err - (eval (car (read-from-string sexp))) - (error - (display-warning - 'diary - (format "Bad diary sexp at line %d in %s:\n%s\n\ -Error: %s\n" - (count-lines (point-min) (point)) - diary-file sexp err) - :error) - nil)))))) + (let ((result + (calendar-dlet* ((date date) + (entry entry)) + (if calendar-debug-sexp + (let ((debug-on-error t)) + (eval (car (read-from-string sexp)))) + (condition-case err + (eval (car (read-from-string sexp))) + (error + (display-warning + 'diary + (format "Bad diary sexp at line %d in %s:\n%s\n\ +Error: %S\n" + (count-lines (point-min) (point)) + diary-file sexp err) + :error) + nil)))))) (cond ((stringp result) result) ((and (consp result) - (stringp (cdr result))) result) + (stringp (cdr result))) + result) (result entry) (t nil)))) -(defvar displayed-year) ; bound in calendar-generate -(defvar displayed-month) - (defun diary-mark-sexp-entries () "Mark days in the calendar window that have sexp diary entries. Each entry in the diary file (or included files) visible in the calendar window @@ -1532,7 +1545,7 @@ passed to `calendar-mark-visible-date' as MARK." (let ((m displayed-month) (y displayed-year)) (calendar-increment-month m y -1) - (dotimes (_idummy 3) + (dotimes (_ 3) (calendar-mark-month m y month day year color) (calendar-increment-month m y 1))))) @@ -1814,9 +1827,6 @@ form used internally by the calendar and diary." ;;; Sexp diary functions. -(defvar date) -(defvar entry) - ;; To be called from diary-sexp-entry, where DATE, ENTRY are bound. (defun diary-date (month day year &optional mark) "Specific date(s) diary entry. @@ -1827,6 +1837,7 @@ of the input parameters changes according to `calendar-date-style' An optional parameter MARK specifies a face or single-character string to use when highlighting the day in the calendar." + (with-no-warnings (defvar date) (defvar entry)) (let* ((ddate (diary-make-date month day year)) (dd (calendar-extract-day ddate)) (mm (calendar-extract-month ddate)) @@ -1855,6 +1866,7 @@ of the input parameters changes according to `calendar-date-style' An optional parameter MARK specifies a face or single-character string to use when highlighting the day in the calendar." + (with-no-warnings (defvar date) (defvar entry)) (let ((date1 (calendar-absolute-from-gregorian (diary-make-date m1 d1 y1))) (date2 (calendar-absolute-from-gregorian @@ -1873,6 +1885,7 @@ DAY defaults to 1 if N>0, and MONTH's last day otherwise. MONTH can be a list of months, an integer, or t (meaning all months). Optional MARK specifies a face or single-character string to use when highlighting the day in the calendar." + (with-no-warnings (defvar date) (defvar entry)) ;; This is messy because the diary entry may apply, but the date on which it ;; is based can be in a different month/year. For example, asking for the ;; first Monday after December 30. For large values of |n| the problem is @@ -1951,6 +1964,7 @@ is considered to be March 1 in non-leap years. An optional parameter MARK specifies a face or single-character string to use when highlighting the day in the calendar." + (with-no-warnings (defvar date) (defvar entry)) (let* ((ddate (diary-make-date month day year)) (dd (calendar-extract-day ddate)) (mm (calendar-extract-month ddate)) @@ -1975,6 +1989,7 @@ and %s by the ordinal ending of that number (that is, `st', `nd', An optional parameter MARK specifies a face or single-character string to use when highlighting the day in the calendar." + (with-no-warnings (defvar date) (defvar entry)) (or (> n 0) (user-error "Day count must be positive")) (let* ((diff (- (calendar-absolute-from-gregorian date) @@ -1986,6 +2001,7 @@ string to use when highlighting the day in the calendar." (defun diary-day-of-year () "Day of year and number of days remaining in the year of date diary entry." + (with-no-warnings (defvar date)) (calendar-day-of-year-string date)) (defun diary-remind (sexp days &optional marking) @@ -2007,11 +2023,12 @@ whether the entry itself is a marking or nonmarking; if optional parameter MARKING is non-nil then the reminders are marked on the calendar." ;; `date' has a value at this point, from diary-sexp-entry. + (with-no-warnings (defvar date)) ;; Convert a negative number to a list of days. (and (integerp days) (< days 0) (setq days (number-sequence 1 (- days)))) - (let ((diary-entry (eval sexp))) + (calendar-dlet* ((diary-entry (eval sexp))) (cond ;; Diary entry applies on date. ((and diary-entry @@ -2027,7 +2044,7 @@ calendar." (when (setq diary-entry (eval sexp)) ;; Discard any mark portion from diary-anniversary, etc. (if (consp diary-entry) (setq diary-entry (cdr diary-entry))) - (mapconcat 'eval diary-remind-message "")))) + (mapconcat #'eval diary-remind-message "")))) ;; Diary entry may apply to one of a list of days before date. ((and (listp days) days) (or (diary-remind sexp (car days) marking) @@ -2224,18 +2241,19 @@ If given, optional SYMBOL must be a prefix to entries. If optional ABBREV-ARRAY is present, also matches the abbreviations from this array (with or without a final `.'), in addition to the full month names." - (let ((dayname (diary-name-pattern calendar-day-name-array - calendar-day-abbrev-array t)) - (monthname (format "\\(%s\\|\\*\\)" - (diary-name-pattern month-array abbrev-array))) - (month "\\([0-9]+\\|\\*\\)") - (day "\\([0-9]+\\|\\*\\)") - (year "-?\\([0-9]+\\|\\*\\)")) + (calendar-dlet* + ((dayname (diary-name-pattern calendar-day-name-array + calendar-day-abbrev-array t)) + (monthname (format "\\(%s\\|\\*\\)" + (diary-name-pattern month-array abbrev-array))) + (month "\\([0-9]+\\|\\*\\)") + (day "\\([0-9]+\\|\\*\\)") + (year "-?\\([0-9]+\\|\\*\\)")) (mapcar (lambda (x) (cons (concat "^" (regexp-quote diary-nonmarking-symbol) "?" (if symbol (regexp-quote symbol) "") "\\(" - (mapconcat 'eval + (mapconcat #'eval ;; If backup, omit first item (backup) ;; and last item (not part of date). (if (equal (car x) 'backup) @@ -2312,7 +2330,7 @@ return a font-lock pattern matching array of MONTHS and marking SYMBOL." 'font-lock-constant-face) (cons (format "^%s?%s" (regexp-quote diary-nonmarking-symbol) - (regexp-opt (mapcar 'regexp-quote + (regexp-opt (mapcar #'regexp-quote (list diary-hebrew-entry-symbol diary-islamic-entry-symbol diary-bahai-entry-symbol @@ -2345,10 +2363,10 @@ return a font-lock pattern matching array of MONTHS and marking SYMBOL." (set (make-local-variable 'comment-start) diary-comment-start) (set (make-local-variable 'comment-end) diary-comment-end) (add-to-invisibility-spec '(diary . nil)) - (add-hook 'after-save-hook 'diary-redraw-calendar nil t) + (add-hook 'after-save-hook #'diary-redraw-calendar nil t) ;; In case the file was modified externally, refresh the calendar ;; after refreshing the diary buffer. - (add-hook 'after-revert-hook 'diary-redraw-calendar nil t) + (add-hook 'after-revert-hook #'diary-redraw-calendar nil t) (if diary-header-line-flag (setq header-line-format diary-header-line-format))) @@ -2359,18 +2377,19 @@ return a font-lock pattern matching array of MONTHS and marking SYMBOL." "Return a regexp matching the first line of a fancy diary date header. This depends on the calendar date style." (concat - (let ((dayname (diary-name-pattern calendar-day-name-array nil t)) - (monthname (diary-name-pattern calendar-month-name-array nil t)) - (day "1") - (month "2") - ;; FIXME? This used to be "-?[0-9]+" - what was the "-?" for? - (year "3")) + (calendar-dlet* + ((dayname (diary-name-pattern calendar-day-name-array nil t)) + (monthname (diary-name-pattern calendar-month-name-array nil t)) + (day "1") + (month "2") + ;; FIXME? This used to be "-?[0-9]+" - what was the "-?" for? + (year "3")) ;; This is ugly. c-d-d-form expects `day' etc to be "numbers in ;; string form"; eg the iso version calls string-to-number on some. ;; Therefore we cannot eg just let day = "[0-9]+". (Bug#8583). ;; Assumes no integers in c-day/month-name-array. (replace-regexp-in-string "[0-9]+" "[0-9]+" - (mapconcat 'eval calendar-date-display-form "") + (mapconcat #'eval calendar-date-display-form "") nil t)) ;; Optional ": holiday name" after the date. "\\(: .*\\)?")) @@ -2391,7 +2410,8 @@ This depends on the calendar date style." ("^Day.*omer.*$" . font-lock-builtin-face) ("^Parashat.*$" . font-lock-comment-face) (,(format "\\(^\\|\\s-\\)%s\\(-%s\\)?" diary-time-regexp - diary-time-regexp) . 'diary-time)) + diary-time-regexp) + . 'diary-time)) "Keywords to highlight in fancy diary display.") ;; If region looks like it might start or end in the middle of a diff --git a/lisp/calendar/solar.el b/lisp/calendar/solar.el index 1e1656cd319..ddaf7451bd9 100644 --- a/lisp/calendar/solar.el +++ b/lisp/calendar/solar.el @@ -1,4 +1,4 @@ -;;; solar.el --- calendar functions for solar events +;;; solar.el --- calendar functions for solar events -*- lexical-binding:t -*- ;; Copyright (C) 1992-1993, 1995, 1997, 2001-2018 Free Software ;; Foundation, Inc. @@ -552,12 +552,14 @@ degrees to find out if polar regions have 24 hours of sun or only night." "Printable form for decimal fraction TIME in TIME-ZONE. Format used is given by `calendar-time-display-form'." (let* ((time (round (* 60 time))) - (24-hours (/ time 60)) + (24-hours (/ time 60))) + (calendar-dlet* + ((time-zone time-zone) (minutes (format "%02d" (% time 60))) (12-hours (format "%d" (1+ (% (+ 24-hours 11) 12)))) (am-pm (if (>= 24-hours 12) "pm" "am")) (24-hours (format "%02d" 24-hours))) - (mapconcat 'eval calendar-time-display-form ""))) + (mapconcat #'eval calendar-time-display-form "")))) (defun solar-daylight (time) "Printable form for TIME expressed in hours." @@ -661,10 +663,10 @@ Optional NOLOCATION non-nil means do not print the location." (format "%s, %s%s (%s hrs daylight)" (if (car l) - (concat "Sunrise " (apply 'solar-time-string (car l))) + (concat "Sunrise " (apply #'solar-time-string (car l))) "No sunrise") (if (cadr l) - (concat "sunset " (apply 'solar-time-string (cadr l))) + (concat "sunset " (apply #'solar-time-string (cadr l))) "no sunset") (if nolocation "" (format " at %s" (eval calendar-location-name))) @@ -749,7 +751,7 @@ The values of `calendar-daylight-savings-starts', (+ 4.9353929 (* 62833.1961680 U) (* 0.0000001 - (apply '+ + (apply #'+ (mapcar (lambda (x) (* (car x) (sin (mod @@ -889,13 +891,12 @@ Accurate to a few seconds." (insert (format "%s %2d: " (calendar-month-name month t) (1+ i)) (solar-sunrise-sunset-string date t) "\n"))))) -(defvar date) - -;; To be called from diary-list-sexp-entries, where DATE is bound. ;;;###diary-autoload (defun diary-sunrise-sunset () "Local time of sunrise and sunset as a diary entry. Accurate to a few seconds." + ;; To be called from diary-list-sexp-entries, where DATE is bound. + (with-no-warnings (defvar date)) (or (and calendar-latitude calendar-longitude calendar-time-zone) (solar-setup)) (solar-sunrise-sunset-string date)) @@ -938,7 +939,7 @@ Accurate to within a minute between 1951 and 2050." (W (- (* 35999.373 T) 2.47)) (Delta-lambda (+ 1 (* 0.0334 (solar-cosine-degrees W)) (* 0.0007 (solar-cosine-degrees (* 2 W))))) - (S (apply '+ (mapcar (lambda(x) + (S (apply #'+ (mapcar (lambda(x) (* (car x) (solar-cosine-degrees (+ (* (nth 2 x) T) (cadr x))))) solar-seasons-data))) diff --git a/lisp/calendar/todo-mode.el b/lisp/calendar/todo-mode.el index 70e6bdf4341..4246ca5a38a 100644 --- a/lisp/calendar/todo-mode.el +++ b/lisp/calendar/todo-mode.el @@ -188,25 +188,17 @@ The final element is \"*\", indicating an unspecified month.") "Array of abbreviated month names, in order. The final element is \"*\", indicating an unspecified month.") -(with-no-warnings - ;; FIXME: These vars lack a prefix, but this is out of our control, because - ;; they're defined by Calendar, e.g. for calendar-date-display-form. - (defvar dayname) - (defvar monthname) - (defvar day) - (defvar month) - (defvar year)) - (defconst todo-date-pattern (let ((dayname (diary-name-pattern calendar-day-name-array nil t))) (concat "\\(?4:\\(?5:" dayname "\\)\\|" - (let ((dayname) - (monthname (format "\\(?6:%s\\)" (diary-name-pattern - todo-month-name-array - todo-month-abbrev-array))) - (month "\\(?7:[0-9]+\\|\\*\\)") - (day "\\(?8:[0-9]+\\|\\*\\)") - (year "-?\\(?9:[0-9]+\\|\\*\\)")) + (calendar-dlet* + ((dayname) + (monthname (format "\\(?6:%s\\)" (diary-name-pattern + todo-month-name-array + todo-month-abbrev-array))) + (month "\\(?7:[0-9]+\\|\\*\\)") + (day "\\(?8:[0-9]+\\|\\*\\)") + (year "-?\\(?9:[0-9]+\\|\\*\\)")) (mapconcat #'eval calendar-date-display-form "")) "\\)")) "Regular expression matching a todo item date header.") @@ -2274,8 +2266,8 @@ made in the number or names of categories." ;; `todo-edit-item' as e.g. `-' or `C-u'. (inc (prefix-numeric-value inc)) (buffer-read-only nil) - ndate ntime year monthname month day - dayname) ; Needed by calendar-date-display-form. + ndate ntime + year monthname month day dayname) (when marked (todo--user-error-if-marked-done-item)) (save-excursion (or (and marked (goto-char (point-min))) (todo-item-start)) @@ -2416,7 +2408,15 @@ made in the number or names of categories." ;; If year, month or day date string components were ;; changed, rebuild the date string. (when (memq what '(year month day)) - (setq ndate (mapconcat #'eval calendar-date-display-form "")))) + (setq ndate + (calendar-dlet* + ;; Needed by calendar-date-display-form. + ((year year) + (monthname monthname) + (month month) + (day day) + (dayname dayname)) + (mapconcat #'eval calendar-date-display-form ""))))) (when ndate (replace-match ndate nil nil nil 1)) ;; Add new time string to the header, if it was supplied. (when ntime @@ -4613,12 +4613,13 @@ strings built using the default value of (defun todo-convert-legacy-date-time () "Return converted date-time string. Helper function for `todo-convert-legacy-files'." - (let* ((year (match-string 1)) - (month (match-string 2)) - (monthname (calendar-month-name (string-to-number month) t)) - (day (match-string 3)) - (time (match-string 4)) - dayname) + (calendar-dlet* + ((year (match-string 1)) + (month (match-string 2)) + (monthname (calendar-month-name (string-to-number month) t)) + (day (match-string 3)) + (time (match-string 4)) + dayname) (replace-match "") (insert (mapconcat #'eval calendar-date-display-form "") (when time (concat " " time))))) @@ -5990,8 +5991,8 @@ indicating an unspecified month, day, or year. When ARG is `day', non-nil arguments MO and YR determine the number of the last the day of the month." - (let (year monthname month day - dayname) ; Needed by calendar-date-display-form. + (calendar-dlet* + (year monthname month day dayname) ;Needed by calendar-date-display-form. (when (or (not arg) (eq arg 'year)) (while (if (natnump year) (< year 1) (not (eq year '*))) (setq year (read-from-minibuffer diff --git a/lisp/cedet/ede/detect.el b/lisp/cedet/ede/detect.el index 5b708ae436e..2b5086a1c5a 100644 --- a/lisp/cedet/ede/detect.el +++ b/lisp/cedet/ede/detect.el @@ -195,11 +195,10 @@ Return a cons cell: "Run a quick test for autodetecting on BUFFER." (interactive) (let ((start (current-time)) - (ans (ede-detect-directory-for-project default-directory)) - (end (current-time))) + (ans (ede-detect-directory-for-project default-directory))) (if ans (message "Project found in %d sec @ %s of type %s" - (float-time (time-subtract end start)) + (float-time (time-subtract nil start)) (car ans) (eieio-object-name-string (cdr ans))) (message "No Project found.") ))) diff --git a/lisp/cedet/pulse.el b/lisp/cedet/pulse.el index a3fa80a6948..e34b51f3521 100644 --- a/lisp/cedet/pulse.el +++ b/lisp/cedet/pulse.el @@ -196,11 +196,11 @@ Optional argument FACE specifies the face to do the highlighting." (pulse-reset-face face) (setq pulse-momentary-timer (run-with-timer 0 pulse-delay #'pulse-tick - (time-add (current-time) + (time-add nil (* pulse-delay pulse-iterations))))))) (defun pulse-tick (stop-time) - (if (time-less-p (current-time) stop-time) + (if (time-less-p nil stop-time) (pulse-lighten-highlight) (pulse-momentary-unhighlight))) diff --git a/lisp/cedet/semantic.el b/lisp/cedet/semantic.el index 4b2f5d2209a..b24e2fbbb1b 100644 --- a/lisp/cedet/semantic.el +++ b/lisp/cedet/semantic.el @@ -389,10 +389,9 @@ the output buffer." (if clear (semantic-clear-toplevel-cache)) (if (eq clear '-) (setq clear -1)) (let* ((start (current-time)) - (out (semantic-fetch-tags)) - (end (current-time))) + (out (semantic-fetch-tags))) (message "Retrieving tags took %.2f seconds." - (semantic-elapsed-time start end)) + (semantic-elapsed-time start nil)) (when (or (null clear) (not (listp clear)) (and (numberp clear) (< 0 clear))) (pop-to-buffer "*Parser Output*") diff --git a/lisp/cedet/semantic/analyze.el b/lisp/cedet/semantic/analyze.el index 2162df455ab..8f3d5b2b1cf 100644 --- a/lisp/cedet/semantic/analyze.el +++ b/lisp/cedet/semantic/analyze.el @@ -440,12 +440,11 @@ to provide a large number of non-cached analysis for filtering symbols." (defun semantic-analyze-current-symbol-default (analyzehookfcn position) "Call ANALYZEHOOKFCN on the analyzed symbol at POSITION." (let* ((semantic-analyze-error-stack nil) - (LLstart (current-time)) + ;; (LLstart (current-time)) (prefixandbounds (semantic-ctxt-current-symbol-and-bounds (or position (point)))) (prefix (car prefixandbounds)) (bounds (nth 2 prefixandbounds)) (scope (semantic-calculate-scope position)) - (end nil) ) ;; Only do work if we have bounds (meaning a prefix to complete) (when bounds @@ -464,15 +463,13 @@ to provide a large number of non-cached analysis for filtering symbols." prefix scope 'prefixtypes)) (error (semantic-analyze-push-error err)))) - (setq end (current-time)) - ;;(message "Analysis took %.2f sec" (semantic-elapsed-time LLstart end)) + ;;(message "Analysis took %.2f sec" (semantic-elapsed-time LLstart nil)) ) (when prefix (prog1 (funcall analyzehookfcn (car bounds) (cdr bounds) prefix) - ;;(setq end (current-time)) - ;;(message "hookfcn took %.5f sec" (semantic-elapsed-time LLstart end)) + ;;(message "hookfcn took %.5f sec" (semantic-elapsed-time LLstart nil)) ) ))) @@ -723,12 +720,11 @@ Optional argument CTXT is the context to show." (interactive) (require 'data-debug) (let ((start (current-time)) - (ctxt (or ctxt (semantic-analyze-current-context))) - (end (current-time))) + (ctxt (or ctxt (semantic-analyze-current-context)))) (if (not ctxt) (message "No Analyzer Results") (message "Analysis took %.2f seconds." - (semantic-elapsed-time start end)) + (semantic-elapsed-time start nil)) (semantic-analyze-pulse ctxt) (if ctxt (progn diff --git a/lisp/cedet/semantic/analyze/refs.el b/lisp/cedet/semantic/analyze/refs.el index d4da9e3170e..6268da80650 100644 --- a/lisp/cedet/semantic/analyze/refs.el +++ b/lisp/cedet/semantic/analyze/refs.el @@ -317,9 +317,8 @@ Only works for tags in the global namespace." (let* ((tag (semantic-current-tag)) (start (current-time)) (sac (semantic-analyze-tag-references tag)) - (end (current-time)) ) - (message "Analysis took %.2f seconds." (semantic-elapsed-time start end)) + (message "Analysis took %.2f seconds." (semantic-elapsed-time start nil)) (if sac (progn (require 'eieio-datadebug) diff --git a/lisp/cedet/semantic/lex.el b/lisp/cedet/semantic/lex.el index 9a35dd82f06..2f216e6e00c 100644 --- a/lisp/cedet/semantic/lex.el +++ b/lisp/cedet/semantic/lex.el @@ -657,10 +657,9 @@ If universal argument ARG, then try the whole buffer." (let* ((start (current-time)) (result (semantic-lex (if arg (point-min) (point)) - (point-max))) - (end (current-time))) + (point-max)))) (message "Elapsed Time: %.2f seconds." - (semantic-elapsed-time start end)) + (semantic-elapsed-time start nil)) (pop-to-buffer "*Lexer Output*") (require 'pp) (erase-buffer) @@ -810,7 +809,7 @@ analyzer which might mistake a number for as a symbol." tmp-start (car semantic-lex-token-stream))) (setq tmp-start semantic-lex-end-point) (goto-char semantic-lex-end-point) - ;;(when (> (semantic-elapsed-time starttime (current-time)) + ;;(when (> (semantic-elapsed-time starttime nil) ;; semantic-lex-timeout) ;; (error "Timeout during lex at char %d" (point))) (semantic-throw-on-input 'lex) diff --git a/lisp/cedet/semantic/symref/filter.el b/lisp/cedet/semantic/symref/filter.el index 0e8ac6392c8..726ef590742 100644 --- a/lisp/cedet/semantic/symref/filter.el +++ b/lisp/cedet/semantic/symref/filter.el @@ -103,7 +103,7 @@ tag that contains point, and return that." (when (called-interactively-p 'interactive) (message "Found %d occurrences of %s in %.2f seconds" Lcount (semantic-tag-name target) - (semantic-elapsed-time start (current-time)))) + (semantic-elapsed-time start nil))) Lcount))) (defun semantic-symref-rename-local-variable () diff --git a/lisp/cedet/srecode/dictionary.el b/lisp/cedet/srecode/dictionary.el index 4a84693fe7e..f1287f68022 100644 --- a/lisp/cedet/srecode/dictionary.el +++ b/lisp/cedet/srecode/dictionary.el @@ -612,10 +612,9 @@ STATE is the current compiler state." (srecode-get-mode-table modesym)) (error "No table found for mode %S" modesym))) (dict (srecode-create-dictionary (current-buffer))) - (end (current-time)) ) (message "Creating a dictionary took %.2f seconds." - (semantic-elapsed-time start end)) + (semantic-elapsed-time start nil)) (data-debug-new-buffer "*SRECODE ADEBUG*") (data-debug-insert-object-slots dict "*"))) diff --git a/lisp/cedet/srecode/map.el b/lisp/cedet/srecode/map.el index 7c9424945f0..f885b49614d 100644 --- a/lisp/cedet/srecode/map.el +++ b/lisp/cedet/srecode/map.el @@ -224,10 +224,9 @@ Optional argument RESET forces a reset of the current map." (require 'data-debug) (let ((start (current-time)) (p (srecode-get-maps t)) ;; Time the reset. - (end (current-time)) ) (message "Updating the map took %.2f seconds." - (semantic-elapsed-time start end)) + (semantic-elapsed-time start nil)) (data-debug-new-buffer "*SRECODE ADEBUG*") (data-debug-insert-stuff-list p "*"))) diff --git a/lisp/comint.el b/lisp/comint.el index 4ca7b500b2d..719945a831f 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -364,10 +364,10 @@ This variable is buffer-local." "\\(?:" (regexp-opt password-word-equivalents) "\\|Response\\)" "\\(?:\\(?:, try\\)? *again\\| (empty for no passphrase)\\| (again)\\)?" ;; "[[:alpha:]]" used to be "for", which fails to match non-English. - "\\(?: [[:alpha:]]+ .+\\)?[:：៖]\\s *\\'") + "\\(?: [[:alpha:]]+ .+\\)?[\\s ]*[:：៖][\\s ]*\\'") "Regexp matching prompts for passwords in the inferior process. This is used by `comint-watch-for-password-prompt'." - :version "26.1" + :version "27.1" :type 'regexp :group 'comint) diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 878256a696e..8284e91b790 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -986,7 +986,7 @@ If given a prefix (or a COMMENT argument), also prompt for a comment." current-prefix-arg)) (custom-load-symbol variable) (custom-push-theme 'theme-value variable 'user 'set (custom-quote value)) - (funcall (or (get variable 'custom-set) 'set-default) variable value) + (funcall (or (get variable 'custom-set) #'set-default) variable value) (put variable 'customized-value (list (custom-quote value))) (cond ((string= comment "") (put variable 'variable-comment nil) @@ -2431,6 +2431,18 @@ If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"." ;;; The `custom-variable' Widget. +(defface custom-variable-obsolete + '((((class color) (background dark)) + :foreground "light blue") + (((min-colors 88) (class color) (background light)) + :foreground "blue1") + (((class color) (background light)) + :foreground "blue") + (t :slant italic)) + "Face used for obsolete variables." + :version "27.1" + :group 'custom-faces) + (defface custom-variable-tag `((((class color) (background dark)) :foreground "light blue" :weight bold) @@ -2456,8 +2468,9 @@ If INITIAL-STRING is non-nil, use that rather than \"Parent groups:\"." (defun custom-variable-documentation (variable) "Return documentation of VARIABLE for use in Custom buffer. Normally just return the docstring. But if VARIABLE automatically -becomes buffer local when set, append a message to that effect." - (format "%s%s" (documentation-property variable 'variable-documentation t) +becomes buffer local when set, append a message to that effect. +Also append any obsolescence information." + (format "%s%s%s" (documentation-property variable 'variable-documentation t) (if (and (local-variable-if-set-p variable) (or (not (local-variable-p variable)) (with-temp-buffer @@ -2465,7 +2478,21 @@ becomes buffer local when set, append a message to that effect." "\n This variable automatically becomes buffer-local when set outside Custom. However, setting it through Custom sets the default value." - ""))) + "") + ;; This duplicates some code from describe-variable. + ;; TODO extract to separate utility function? + (let* ((obsolete (get variable 'byte-obsolete-variable)) + (use (car obsolete))) + (if obsolete + (concat "\n +This variable is obsolete" + (if (nth 2 obsolete) + (format " since %s" (nth 2 obsolete))) + (cond ((stringp use) (concat ";\n" use)) + (use (format-message ";\nuse `%s' instead." + (car obsolete))) + (t "."))) + "")))) (define-widget 'custom-variable 'custom "A widget for displaying a Custom variable. @@ -2549,7 +2576,8 @@ try matching its doc string against `custom-guess-doc-alist'." (state (or (widget-get widget :custom-state) (if (memq (custom-variable-state symbol value) (widget-get widget :hidden-states)) - 'hidden)))) + 'hidden))) + (obsolete (get symbol 'byte-obsolete-variable))) ;; If we don't know the state, see if we need to edit it in lisp form. (unless state @@ -2581,7 +2609,9 @@ try matching its doc string against `custom-guess-doc-alist'." (push (widget-create-child-and-convert widget 'item :format "%{%t%} " - :sample-face 'custom-variable-tag + :sample-face (if obsolete + 'custom-variable-obsolete + 'custom-variable-tag) :tag tag :parent widget) buttons)) @@ -2639,7 +2669,9 @@ try matching its doc string against `custom-guess-doc-alist'." :help-echo "Change value of this option." :mouse-down-action 'custom-tag-mouse-down-action :button-face 'custom-variable-button - :sample-face 'custom-variable-tag + :sample-face (if obsolete + 'custom-variable-obsolete + 'custom-variable-tag) tag) buttons) (push (widget-create-child-and-convert @@ -3322,6 +3354,23 @@ Only match frames that support the specified face attributes.") :group 'custom-buffer :version "20.3") +(defun custom-face-documentation (face) + "Return documentation of FACE for use in Custom buffer." + (format "%s%s" (face-documentation face) + ;; This duplicates some code from describe-face. + ;; TODO extract to separate utility function? + ;; In practice this does not get used, because M-x customize-face + ;; follows aliases. + (let ((alias (get face 'face-alias)) + (obsolete (get face 'obsolete-face))) + (if (and alias obsolete) + (format "\nThis face is obsolete%s; use `%s' instead.\n" + (if (stringp obsolete) + (format " since %s" obsolete) + "") + alias) + "")))) + (define-widget 'custom-face 'custom "Widget for customizing a face. The following properties have special meanings for this widget: @@ -3345,7 +3394,7 @@ The following properties have special meanings for this widget: of the widget, instead of the current face spec." :sample-face 'custom-face-tag :help-echo "Set or reset this face." - :documentation-property #'face-doc-string + :documentation-property #'custom-face-documentation :value-create 'custom-face-value-create :action 'custom-face-action :custom-category 'face diff --git a/lisp/delim-col.el b/lisp/delim-col.el index 5acb23922c2..076d4dc5c3d 100644 --- a/lisp/delim-col.el +++ b/lisp/delim-col.el @@ -2,8 +2,8 @@ ;; Copyright (C) 1999-2018 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> -;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> +;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Version: 2.1 ;; Keywords: internal ;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre diff --git a/lisp/desktop.el b/lisp/desktop.el index 069d273d1d1..420d62a366f 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el @@ -1563,8 +1563,7 @@ and try to load that." (setq buffer-display-time (if buffer-display-time (time-add buffer-display-time - (time-subtract (current-time) - desktop-file-modtime)) + (time-subtract nil desktop-file-modtime)) (current-time))) (unless (< desktop-file-version 208) ; Don't misinterpret any old custom args (dolist (record compacted-vars) diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 0af68c1f1b2..7fff7e7a240 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -1548,6 +1548,24 @@ Special value `always' suppresses confirmation." (declare-function make-symbolic-link "fileio.c") +(defcustom dired-create-destination-dirs nil + "Whether Dired should create destination dirs when copying/removing files. +If nil, don't create them. +If `always', create them without ask. +If `ask', ask for user confirmation." + :type '(choice (const :tag "Never create non-existent dirs" nil) + (const :tag "Always create non-existent dirs" always) + (const :tag "Ask for user confirmation" ask)) + :group 'dired + :version "27.1") + +(defun dired-maybe-create-dirs (dir) + "Create DIR if doesn't exist according to `dired-create-destination-dirs'." + (when (and dired-create-destination-dirs (not (file-exists-p dir))) + (if (or (eq dired-create-destination-dirs 'always) + (yes-or-no-p (format "Create destination dir `%s'? " dir))) + (dired-create-directory dir)))) + (defun dired-copy-file-recursive (from to ok-flag &optional preserve-time top recursive) (when (and (eq t (car (file-attributes from))) @@ -1564,6 +1582,7 @@ Special value `always' suppresses confirmation." (if (stringp (car attrs)) ;; It is a symlink (make-symbolic-link (car attrs) to ok-flag) + (dired-maybe-create-dirs (file-name-directory to)) (copy-file from to ok-flag preserve-time)) (file-date-error (push (dired-make-relative from) @@ -1573,6 +1592,7 @@ Special value `always' suppresses confirmation." ;;;###autoload (defun dired-rename-file (file newname ok-if-already-exists) (dired-handle-overwrite newname) + (dired-maybe-create-dirs (file-name-directory newname)) (rename-file file newname ok-if-already-exists) ; error is caught in -create-files ;; Silently rename the visited file of any buffer visiting this file. (and (get-file-buffer file) diff --git a/lisp/dired.el b/lisp/dired.el index c421e51ffd1..b853d64c563 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -198,8 +198,10 @@ The target is used in the prompt for file copy, rename etc." ; These variables were deleted and the replacements are on files.el. ; We leave aliases behind for back-compatibility. -(defvaralias 'dired-free-space-program 'directory-free-space-program) -(defvaralias 'dired-free-space-args 'directory-free-space-args) +(define-obsolete-variable-alias 'dired-free-space-program + 'directory-free-space-program "27.1") +(define-obsolete-variable-alias 'dired-free-space-args + 'directory-free-space-args "27.1") ;;; Hook variables diff --git a/lisp/electric.el b/lisp/electric.el index c146b3ceaeb..c00e7c00a59 100644 --- a/lisp/electric.el +++ b/lisp/electric.el @@ -451,6 +451,14 @@ whitespace, opening parenthesis, or quote and leaves \\=` alone." :version "26.1" :type 'boolean :safe #'booleanp :group 'electricity) +(defcustom electric-quote-replace-double nil + "Non-nil means to replace \" with an electric double quote. +Emacs replaces \" with an opening double quote after a line +break, whitespace, opening parenthesis, or quote, and with a +closing double quote otherwise." + :version "26.1" + :type 'boolean :safe #'booleanp :group 'electricity) + (defvar electric-quote-inhibit-functions () "List of functions that should inhibit electric quoting. When the variable `electric-quote-mode' is non-nil, Emacs will @@ -461,13 +469,17 @@ substitution is inhibited. The functions are called after the after the inserted character. The functions in this hook should not move point or change the current buffer.") +(defvar electric-pair-text-pairs) + (defun electric-quote-post-self-insert-function () "Function that `electric-quote-mode' adds to `post-self-insert-hook'. This requotes when a quoting key is typed." (when (and electric-quote-mode (or (eq last-command-event ?\') (and (not electric-quote-context-sensitive) - (eq last-command-event ?\`))) + (eq last-command-event ?\`)) + (and electric-quote-replace-double + (eq last-command-event ?\"))) (not (run-hook-with-args-until-success 'electric-quote-inhibit-functions)) (if (derived-mode-p 'text-mode) @@ -488,9 +500,12 @@ This requotes when a quoting key is typed." (save-excursion (let ((backtick ?\`)) (if (or (eq last-command-event ?\`) - (and electric-quote-context-sensitive + (and (or electric-quote-context-sensitive + (and electric-quote-replace-double + (eq last-command-event ?\"))) (save-excursion (backward-char) + (skip-syntax-backward "\\") (or (bobp) (bolp) (memq (char-before) (list q< q<<)) (memq (char-syntax (char-before)) @@ -506,13 +521,19 @@ This requotes when a quoting key is typed." (setq last-command-event q<<)) ((search-backward (string backtick) (1- (point)) t) (replace-match (string q<)) - (setq last-command-event q<))) + (setq last-command-event q<)) + ((search-backward "\"" (1- (point)) t) + (replace-match (string q<<)) + (setq last-command-event q<<))) (cond ((search-backward (string q> ?') (- (point) 2) t) (replace-match (string q>>)) (setq last-command-event q>>)) ((search-backward "'" (1- (point)) t) (replace-match (string q>)) - (setq last-command-event q>)))))))))) + (setq last-command-event q>)) + ((search-backward "\"" (1- (point)) t) + (replace-match (string q>>)) + (setq last-command-event q>>)))))))))) (put 'electric-quote-post-self-insert-function 'priority 10) diff --git a/lisp/emacs-lisp/advice.el b/lisp/emacs-lisp/advice.el index 17272328302..49c2d5f4f9f 100644 --- a/lisp/emacs-lisp/advice.el +++ b/lisp/emacs-lisp/advice.el @@ -1514,7 +1514,7 @@ ;; `ad-return-value' in a piece of after advice. For example: ;; ;; (defmacro foom (x) -;; (` (list (, x)))) +;; `(list ,x)) ;; foom ;; ;; (foom '(a)) @@ -1547,8 +1547,8 @@ ;; (defadvice foom (after fg-print-x act) ;; "Print the value of X." ;; (setq ad-return-value -;; (` (progn (print (, x)) -;; (, ad-return-value))))) +;; `(progn (print ,x) +;; ,ad-return-value))) ;; foom ;; ;; (macroexpand '(foom '(a))) diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el index 589e76eaec0..0dc9333d5fa 100644 --- a/lisp/emacs-lisp/benchmark.el +++ b/lisp/emacs-lisp/benchmark.el @@ -34,13 +34,11 @@ (defmacro benchmark-elapse (&rest forms) "Return the time in seconds elapsed for execution of FORMS." (declare (indent 0) (debug t)) - (let ((t1 (make-symbol "t1")) - (t2 (make-symbol "t2"))) - `(let (,t1 ,t2) + (let ((t1 (make-symbol "t1"))) + `(let (,t1) (setq ,t1 (current-time)) ,@forms - (setq ,t2 (current-time)) - (float-time (time-subtract ,t2 ,t1))))) + (float-time (time-subtract nil ,t1))))) ;;;###autoload (defmacro benchmark-run (&optional repetitions &rest forms) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 62e6dd2084b..e5e5f4ee590 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1281,7 +1281,10 @@ ;; errors to compile time. (let ((pure-fns - '(concat symbol-name regexp-opt regexp-quote string-to-syntax))) + '(concat symbol-name regexp-opt regexp-quote string-to-syntax + string-to-char + ash lsh logb lognot logior logxor + ceiling floor))) (while pure-fns (put (car pure-fns) 'pure t) (setq pure-fns (cdr pure-fns))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index acba9e2df5e..cc3a24e3d51 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -2064,14 +2064,8 @@ With argument ARG, insert value in current buffer after the form." (not (eobp))) (setq byte-compile-read-position (point) byte-compile-last-position byte-compile-read-position) - (let* ((lread--old-style-backquotes nil) - (lread--unescaped-character-literals nil) + (let* ((lread--unescaped-character-literals nil) (form (read inbuffer))) - ;; Warn about the use of old-style backquotes. - (when lread--old-style-backquotes - (byte-compile-warn "!! The file uses old-style backquotes !! -This functionality has been obsolete for more than 10 years already -and will be removed soon. See (elisp)Backquote in the manual.")) (when lread--unescaped-character-literals (byte-compile-warn "unescaped character literals %s detected!" @@ -2493,6 +2487,12 @@ list that represents a doc string reference. (mapc 'byte-compile-file-form (cdr form)) nil)) +;; Automatically evaluate define-obsolete-function-alias etc at top-level. +(put 'make-obsolete 'byte-hunk-handler 'byte-compile-file-form-make-obsolete) +(defun byte-compile-file-form-make-obsolete (form) + (prog1 (byte-compile-keep-pending form) + (apply 'make-obsolete (mapcar 'eval (cdr form))))) + ;; This handler is not necessary, but it makes the output from dont-compile ;; and similar macros cleaner. (put 'eval 'byte-hunk-handler 'byte-compile-file-form-eval) @@ -2840,9 +2840,10 @@ for symbols generated by the byte compiler itself." (setq form (cdr form))) (setq form (car form))) (if (and (eq (car-safe form) 'list) - ;; The spec is evalled in callint.c in dynamic-scoping - ;; mode, so just leaving the form unchanged would mean - ;; it won't be eval'd in the right mode. + ;; For code using lexical-binding, form is not + ;; valid lisp, but rather an intermediate form + ;; which may include "calls" to + ;; internal-make-closure (Bug#29988). (not lexical-binding)) nil (setq int `(interactive ,newform))))) diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 4e8ecba4a15..59b7831fb58 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -171,6 +171,7 @@ (defvar checkdoc-version "0.6.1" "Release version of checkdoc you are currently running.") +(eval-when-compile (require 'cl-lib)) (require 'help-mode) ;; for help-xref-info-regexp (require 'thingatpt) ;; for handy thing-at-point-looking-at @@ -436,23 +437,6 @@ be re-created.") st) "Syntax table used by checkdoc in document strings.") -;;; Compatibility -;; -(defalias 'checkdoc-make-overlay - (if (featurep 'xemacs) #'make-extent #'make-overlay)) -(defalias 'checkdoc-overlay-put - (if (featurep 'xemacs) #'set-extent-property #'overlay-put)) -(defalias 'checkdoc-delete-overlay - (if (featurep 'xemacs) #'delete-extent #'delete-overlay)) -(defalias 'checkdoc-overlay-start - (if (featurep 'xemacs) #'extent-start #'overlay-start)) -(defalias 'checkdoc-overlay-end - (if (featurep 'xemacs) #'extent-end #'overlay-end)) -(defalias 'checkdoc-mode-line-update - (if (featurep 'xemacs) #'redraw-modeline #'force-mode-line-update)) -(defalias 'checkdoc-char= - (if (featurep 'xemacs) #'char= #'=)) - ;;; User level commands ;; ;;;###autoload @@ -475,32 +459,31 @@ the users will view as each check is completed." tmp) (checkdoc-display-status-buffer status) ;; check the comments - (if (not buffer-file-name) - (setcar status "Not checked") - (if (checkdoc-file-comments-engine) - (setcar status "Errors") - (setcar status "Ok"))) - (setcar (cdr status) "Checking...") + (setf (nth 0 status) + (cond + ((not buffer-file-name) "Not checked") + ((checkdoc-file-comments-engine) "Errors") + (t "Ok"))) + (setf (nth 1 status) "Checking...") (checkdoc-display-status-buffer status) ;; Check the documentation (setq tmp (checkdoc-interactive nil t)) - (if tmp - (setcar (cdr status) (format "%d Errors" (length tmp))) - (setcar (cdr status) "Ok")) - (setcar (cdr (cdr status)) "Checking...") + (setf (nth 1 status) + (if tmp (format "%d Errors" (length tmp)) "Ok")) + (setf (nth 2 status) "Checking...") (checkdoc-display-status-buffer status) ;; Check the message text - (if (setq tmp (checkdoc-message-interactive nil t)) - (setcar (cdr (cdr status)) (format "%d Errors" (length tmp))) - (setcar (cdr (cdr status)) "Ok")) - (setcar (cdr (cdr (cdr status))) "Checking...") + (setf (nth 2 status) + (if (setq tmp (checkdoc-message-interactive nil t)) + (format "%d Errors" (length tmp)) + "Ok")) + (setf (nth 3 status) "Checking...") (checkdoc-display-status-buffer status) ;; Rogue spacing - (if (condition-case nil - (checkdoc-rogue-spaces nil t) - (error t)) - (setcar (cdr (cdr (cdr status))) "Errors") - (setcar (cdr (cdr (cdr status))) "Ok")) + (setf (nth 3 status) + (if (ignore-errors (checkdoc-rogue-spaces nil t)) + "Errors" + "Ok")) (checkdoc-display-status-buffer status))) (defun checkdoc-display-status-buffer (check) @@ -592,16 +575,16 @@ style." (while err-list (goto-char (cdr (car err-list))) ;; The cursor should be just in front of the offending doc string - (if (stringp (car (car err-list))) - (setq cdo (save-excursion (checkdoc-make-overlay + (setq cdo (if (stringp (car (car err-list))) + (save-excursion (make-overlay (point) (progn (forward-sexp 1) - (point))))) - (setq cdo (checkdoc-make-overlay + (point)))) + (make-overlay (checkdoc-error-start (car (car err-list))) (checkdoc-error-end (car (car err-list)))))) (unwind-protect (progn - (checkdoc-overlay-put cdo 'face 'highlight) + (overlay-put cdo 'face 'highlight) ;; Make sure the whole doc string is visible if possible. (sit-for 0) (if (and (= (following-char) ?\") @@ -627,10 +610,10 @@ style." (if (not (integerp c)) (setq c ??)) (cond ;; Exit condition - ((checkdoc-char= c ?\C-g) (signal 'quit nil)) + ((eq c ?\C-g) (signal 'quit nil)) ;; Request an auto-fix - ((or (checkdoc-char= c ?y) (checkdoc-char= c ?f)) - (checkdoc-delete-overlay cdo) + ((memq c '(?y ?f)) + (delete-overlay cdo) (setq cdo nil) (goto-char (cdr (car err-list))) ;; `automatic-then-never' tells the autofix function @@ -659,7 +642,7 @@ style." "No Additional style errors. Continuing...") (sit-for 2)))))) ;; Move to the next error (if available) - ((or (checkdoc-char= c ?n) (checkdoc-char= c ?\s)) + ((memq c '(?n ?\s)) (let ((ne (funcall findfunc nil))) (if (not ne) (if showstatus @@ -671,7 +654,7 @@ style." (sit-for 2)) (setq err-list (cons ne err-list))))) ;; Go backwards in the list of errors - ((or (checkdoc-char= c ?p) (checkdoc-char= c ?\C-?)) + ((memq c '(?p ?\C-?)) (if (/= (length err-list) 1) (progn (setq err-list (cdr err-list)) @@ -680,10 +663,10 @@ style." (message "No Previous Errors.") (sit-for 2))) ;; Edit the buffer recursively. - ((checkdoc-char= c ?e) + ((eq c ?e) (checkdoc-recursive-edit (checkdoc-error-text (car (car err-list)))) - (checkdoc-delete-overlay cdo) + (delete-overlay cdo) (setq err-list (cdr err-list)) ;back up the error found. (beginning-of-defun) (let ((ne (funcall findfunc nil))) @@ -695,7 +678,7 @@ style." (sit-for 2)) (setq err-list (cons ne err-list))))) ;; Quit checkdoc - ((checkdoc-char= c ?q) + ((eq c ?q) (setq returnme err-list err-list nil begin (point))) @@ -723,7 +706,7 @@ style." "C-h - Toggle this help buffer."))) (shrink-window-if-larger-than-buffer (get-buffer-window "*Checkdoc Help*")))))) - (if cdo (checkdoc-delete-overlay cdo))))) + (if cdo (delete-overlay cdo))))) (goto-char begin) (if (get-buffer "*Checkdoc Help*") (kill-buffer "*Checkdoc Help*")) (message "Checkdoc: Done.") @@ -1147,6 +1130,15 @@ Prefix argument is the same as for `checkdoc-defun'" ;; features and behaviors, so we need some ways of specifying ;; them, and making them easier to use in the wacked-out interfaces ;; people are requesting + +(cl-defstruct (checkdoc-error + (:constructor nil) + (:constructor checkdoc--create-error (text start end &optional unfixable))) + (text nil :read-only t) + (start nil :read-only t) + (end nil :read-only t) + (unfixable nil :read-only t)) + (defvar checkdoc-create-error-function #'checkdoc--create-error-for-checkdoc "Function called when Checkdoc encounters an error. Should accept as arguments (TEXT START END &optional UNFIXABLE). @@ -1155,7 +1147,7 @@ TEXT is the descriptive text of the error. START and END define the region it is sensible to highlight when describing the problem. Optional argument UNFIXABLE means that the error has no auto-fix available. -A list of the form (TEXT START END UNFIXABLE) is returned if we are not +An object of type `checkdoc-error' is returned if we are not generating a buffered list of errors.") (defun checkdoc-create-error (text start end &optional unfixable) @@ -1171,27 +1163,7 @@ TEXT, START, END and UNFIXABLE conform to (if checkdoc-generate-compile-warnings-flag (progn (checkdoc-error start text) nil) - (list text start end unfixable))) - -(defun checkdoc-error-text (err) - "Return the text specified in the checkdoc ERR." - ;; string-p part is for backwards compatibility - (if (stringp err) err (car err))) - -(defun checkdoc-error-start (err) - "Return the start point specified in the checkdoc ERR." - ;; string-p part is for backwards compatibility - (if (stringp err) nil (nth 1 err))) - -(defun checkdoc-error-end (err) - "Return the end point specified in the checkdoc ERR." - ;; string-p part is for backwards compatibility - (if (stringp err) nil (nth 2 err))) - -(defun checkdoc-error-unfixable (err) - "Return the t if we cannot autofix the error specified in the checkdoc ERR." - ;; string-p part is for backwards compatibility - (if (stringp err) nil (nth 3 err))) + (checkdoc--create-error text start end unfixable))) ;;; Minor Mode specification ;; @@ -1342,7 +1314,7 @@ See the style guide in the Emacs Lisp manual for more details." (if (and (not (nth 1 fp)) ; not a variable (or (nth 2 fp) ; is interactive checkdoc-force-docstrings-flag) ;or we always complain - (not (checkdoc-char= (following-char) ?\"))) ; no doc string + (not (eq (following-char) ?\"))) ; no doc string ;; Sometimes old code has comments where the documentation should ;; be. Let's see if we can find the comment, and offer to turn it ;; into documentation for them. @@ -1471,9 +1443,9 @@ regexp short cuts work. FP is the function defun information." (if (> (point) e) (goto-char e)) ;of the form (defun n () "doc" nil) (forward-char -1) (cond - ((and (checkdoc-char= (following-char) ?\") + ((and (eq (following-char) ?\") ;; A backslashed double quote at the end of a sentence - (not (checkdoc-char= (preceding-char) ?\\))) + (not (eq (preceding-char) ?\\))) ;; We might have to add a period in this case (forward-char -1) (if (looking-at "[.!?]") @@ -1796,7 +1768,7 @@ function,command,variable,option or symbol." ms1)))))) (let ((lim (save-excursion (end-of-line) ;; check string-continuation - (if (checkdoc-char= (preceding-char) ?\\) + (if (eq (preceding-char) ?\\) (line-end-position 2) (point)))) (rs nil) replace original (case-fold-search t)) @@ -2593,12 +2565,12 @@ This function returns non-nil if the text was replaced. This function will not modify `match-data'." (if (and checkdoc-autofix-flag (not (eq checkdoc-autofix-flag 'never))) - (let ((o (checkdoc-make-overlay start end)) + (let ((o (make-overlay start end)) (ret nil) (md (match-data))) (unwind-protect (progn - (checkdoc-overlay-put o 'face 'highlight) + (overlay-put o 'face 'highlight) (if (or (eq checkdoc-autofix-flag 'automatic) (eq checkdoc-autofix-flag 'automatic-then-never) (and (eq checkdoc-autofix-flag 'semiautomatic) @@ -2615,9 +2587,9 @@ This function will not modify `match-data'." (insert replacewith) (if checkdoc-bouncy-flag (sit-for 0)) (setq ret t))) - (checkdoc-delete-overlay o) + (delete-overlay o) (set-match-data md)) - (checkdoc-delete-overlay o) + (delete-overlay o) (set-match-data md)) (if (eq checkdoc-autofix-flag 'automatic-then-never) (setq checkdoc-autofix-flag 'never)) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index c6996bfc15b..caad62c84f8 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -808,22 +808,26 @@ methods.") ;; able to preload cl-generic without also preloading the byte-compiler, ;; So we use `eval-when-compile' so as not keep it available longer than ;; strictly needed. -(defmacro cl--generic-prefill-dispatchers (arg-or-context specializer) +(defmacro cl--generic-prefill-dispatchers (arg-or-context &rest specializers) (unless (integerp arg-or-context) (setq arg-or-context `(&context . ,arg-or-context))) (unless (fboundp 'cl--generic-get-dispatcher) (require 'cl-generic)) (let ((fun (cl--generic-get-dispatcher - `(,arg-or-context ,@(cl-generic-generalizers specializer) - ,cl--generic-t-generalizer)))) + `(,arg-or-context + ,@(apply #'append + (mapcar #'cl-generic-generalizers specializers)) + ,cl--generic-t-generalizer)))) ;; Recompute dispatch at run-time, since the generalizers may be slightly ;; different (e.g. byte-compiled rather than interpreted). ;; FIXME: There is a risk that the run-time generalizer is not equivalent ;; to the compile-time one, in which case `fun' may not be correct ;; any more! - `(let ((dispatch `(,',arg-or-context - ,@(cl-generic-generalizers ',specializer) - ,cl--generic-t-generalizer))) + `(let ((dispatch + `(,',arg-or-context + ,@(apply #'append + (mapcar #'cl-generic-generalizers ',specializers)) + ,cl--generic-t-generalizer))) ;; (message "Prefilling for %S with \n%S" dispatch ',fun) (puthash dispatch ',fun cl--generic-dispatchers))))) @@ -1205,6 +1209,7 @@ See the full list and their hierarchy in `cl--generic-typeof-types'." (cl-call-next-method))) (cl--generic-prefill-dispatchers 0 integer) +(cl--generic-prefill-dispatchers 0 cl--generic-generalizer integer) ;;; Dispatch on major mode. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index e7f82ced488..43eb4261162 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -555,7 +555,7 @@ its argument list allows full Common Lisp conventions." (if (memq '&environment args) (error "&environment used incorrectly")) (let ((restarg (memq '&rest args)) (safety (if (cl--compiling-file) cl--optimize-safety 3)) - (keys nil) + (keys t) (laterarg nil) (exactarg nil) minarg) (or num (setq num 0)) (setq restarg (if (listp (cadr restarg)) @@ -610,6 +610,7 @@ its argument list allows full Common Lisp conventions." (+ ,num (length ,restarg))))) cl--bind-forms))) (while (and (eq (car args) '&key) (pop args)) + (unless (listp keys) (setq keys nil)) (while (and args (not (memq (car args) cl--lambda-list-keywords))) (let ((arg (pop args))) (or (consp arg) (setq arg (list arg))) @@ -648,23 +649,32 @@ its argument list allows full Common Lisp conventions." `'(nil ,(cl--const-expr-val def)) `(list nil ,def)))))))) (push karg keys))))) - (setq keys (nreverse keys)) + (when (consp keys) (setq keys (nreverse keys))) (or (and (eq (car args) '&allow-other-keys) (pop args)) - (null keys) (= safety 0) - (let* ((var (make-symbol "--cl-keys--")) - (allow '(:allow-other-keys)) - (check `(while ,var - (cond - ((memq (car ,var) ',(append keys allow)) - (setq ,var (cdr (cdr ,var)))) - ((car (cdr (memq (quote ,@allow) ,restarg))) - (setq ,var nil)) - (t - (error - ,(format "Keyword argument %%s not one of %s" - keys) - (car ,var))))))) - (push `(let ((,var ,restarg)) ,check) cl--bind-forms))) + (= safety 0) + (cond + ((eq keys t) nil) ;No &keys at all + ((null keys) ;A &key but no actual keys specified. + (push `(when ,restarg + (error ,(format "Keyword argument %%s not one of %s" + keys) + (car ,restarg))) + cl--bind-forms)) + (t + (let* ((var (make-symbol "--cl-keys--")) + (allow '(:allow-other-keys)) + (check `(while ,var + (cond + ((memq (car ,var) ',(append keys allow)) + (setq ,var (cdr (cdr ,var)))) + ((car (cdr (memq (quote ,@allow) ,restarg))) + (setq ,var nil)) + (t + (error + ,(format "Keyword argument %%s not one of %s" + keys) + (car ,var))))))) + (push `(let ((,var ,restarg)) ,check) cl--bind-forms))))) (cl--do-&aux args) nil))) @@ -882,7 +892,7 @@ This is compatible with Common Lisp, but note that `defun' and (defvar cl--loop-name) (defvar cl--loop-result) (defvar cl--loop-result-explicit) (defvar cl--loop-result-var) (defvar cl--loop-steps) -(defvar cl--loop-symbol-macs) +(defvar cl--loop-symbol-macs) (defvar cl--loop-guard-cond) (defun cl--loop-set-iterator-function (kind iterator) (if cl--loop-iterator-function @@ -951,7 +961,7 @@ 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-guard-cond nil)) ;; Here is more or less how those dynbind vars are used after looping ;; over cl--parse-loop-clause: ;; @@ -986,7 +996,24 @@ For more details, see Info node `(cl)Loop Facility'. (list (or cl--loop-result-explicit cl--loop-result)))) (ands (cl--loop-build-ands (nreverse cl--loop-body))) - (while-body (nconc (cadr ands) (nreverse cl--loop-steps))) + (while-body + (nconc + (cadr ands) + (if (or (not cl--loop-guard-cond) (not cl--loop-first-flag)) + (nreverse cl--loop-steps) + ;; Right after update the loop variable ensure that the loop + ;; condition, i.e. (car ands), is still satisfied; otherwise, + ;; set `cl--loop-first-flag' nil and skip the remaining + ;; body forms (#Bug#29799). + ;; + ;; (last cl--loop-steps) updates the loop var + ;; (car (butlast cl--loop-steps)) sets `cl--loop-first-flag' nil + ;; (nreverse (cdr (butlast cl--loop-steps))) are the + ;; remaining body forms. + (append (last cl--loop-steps) + `((and ,(car ands) + ,@(nreverse (cdr (butlast cl--loop-steps))))) + `(,(car (butlast cl--loop-steps))))))) (body (append (nreverse cl--loop-initially) (list (if cl--loop-iterator-function @@ -1307,11 +1334,13 @@ For more details, see Info node `(cl)Loop Facility'. ((memq word '(across across-ref)) (let ((temp-vec (make-symbol "--cl-vec--")) + (temp-len (make-symbol "--cl-len--")) (temp-idx (make-symbol "--cl-idx--"))) (push (list temp-vec (pop cl--loop-args)) loop-for-bindings) + (push (list temp-len `(length ,temp-vec)) loop-for-bindings) (push (list temp-idx -1) loop-for-bindings) (push `(< (setq ,temp-idx (1+ ,temp-idx)) - (length ,temp-vec)) + ,temp-len) cl--loop-body) (if (eq word 'across-ref) (push (list var `(aref ,temp-vec ,temp-idx)) @@ -1326,6 +1355,7 @@ For more details, see Info node `(cl)Loop Facility'. (error "Expected `of'")))) (seq (cl--pop2 cl--loop-args)) (temp-seq (make-symbol "--cl-seq--")) + (temp-len (make-symbol "--cl-len--")) (temp-idx (if (eq (car cl--loop-args) 'using) (if (and (= (length (cadr cl--loop-args)) 2) @@ -1336,16 +1366,19 @@ 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--"))) + (progn (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)) + ;; Evaluate seq length just if needed, that is, when seq is not a cons. + (push (list temp-len (or (consp seq) `(length ,temp-seq))) + loop-for-bindings) (push (list var nil) loop-for-bindings) (push `(and ,temp-seq (or (consp ,temp-seq) - (< ,temp-idx (length ,temp-seq)))) + (< ,temp-idx ,temp-len))) cl--loop-body) (push (list var `(if (consp ,temp-seq) (pop ,temp-seq) @@ -1490,10 +1523,11 @@ For more details, see Info node `(cl)Loop Facility'. ,(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 + (setq cl--loop-guard-cond t) + (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--"))) @@ -2088,60 +2122,65 @@ except that it additionally expands symbol macros." (setq exp (cons 'setq args)) ;; Don't loop further. nil))) - (`(,(or `let `let*) . ,(or `(,bindings . ,body) dontcare)) - ;; CL's symbol-macrolet treats re-bindings as candidates for - ;; expansion (turning the let into a letf if needed), contrary to - ;; Common-Lisp where such re-bindings hide the symbol-macro. - (let ((letf nil) (found nil) (nbs ())) - (dolist (binding bindings) - (let* ((var (if (symbolp binding) binding (car binding))) - (sm (assq var venv))) - (push (if (not (cdr sm)) - binding - (let ((nexp (cadr sm))) - (setq found t) - (unless (symbolp nexp) (setq letf t)) - (cons nexp (cdr-safe binding)))) - nbs))) - (when found - (setq exp `(,(if letf - (if (eq (car exp) 'let) 'cl-letf 'cl-letf*) - (car exp)) - ,(nreverse nbs) - ,@body))))) - ;; FIXME: The behavior of CL made sense in a dynamically scoped - ;; language, but for lexical scoping, Common-Lisp's behavior might - ;; make more sense (and indeed, CL behaves like Common-Lisp w.r.t - ;; lexical-let), so maybe we should adjust the behavior based on - ;; the use of lexical-binding. + ;; CL's symbol-macrolet used to treat re-bindings as candidates for + ;; expansion (turning the let into a letf if needed), contrary to + ;; Common-Lisp where such re-bindings hide the symbol-macro. + ;; Not sure if there actually is code out there which depends + ;; on this behavior (haven't found any yet). + ;; Such code should explicitly use `cl-letf' instead, I think. + ;; ;; (`(,(or `let `let*) . ,(or `(,bindings . ,body) dontcare)) - ;; (let ((nbs ()) (found nil)) + ;; (let ((letf nil) (found nil) (nbs ())) ;; (dolist (binding bindings) ;; (let* ((var (if (symbolp binding) binding (car binding))) - ;; (name (symbol-name var)) - ;; (val (and found (consp binding) (eq 'let* (car exp)) - ;; (list (macroexpand-all (cadr binding) - ;; env))))) - ;; (push (if (assq name env) - ;; ;; This binding should hide its symbol-macro, - ;; ;; but given the way macroexpand-all works, we - ;; ;; can't prevent application of `env' to the - ;; ;; sub-expressions, so we need to α-rename this - ;; ;; variable instead. - ;; (let ((nvar (make-symbol - ;; (copy-sequence name)))) - ;; (setq found t) - ;; (push (list name nvar) env) - ;; (cons nvar (or val (cdr-safe binding)))) - ;; (if val (cons var val) binding)) + ;; (sm (assq var venv))) + ;; (push (if (not (cdr sm)) + ;; binding + ;; (let ((nexp (cadr sm))) + ;; (setq found t) + ;; (unless (symbolp nexp) (setq letf t)) + ;; (cons nexp (cdr-safe binding)))) ;; nbs))) ;; (when found - ;; (setq exp `(,(car exp) + ;; (setq exp `(,(if letf + ;; (if (eq (car exp) 'let) 'cl-letf 'cl-letf*) + ;; (car exp)) ;; ,(nreverse nbs) - ;; ,@(macroexp-unprogn - ;; (macroexpand-all (macroexp-progn body) - ;; env))))) - ;; nil)) + ;; ,@body))))) + ;; + ;; We implement the Common-Lisp behavior, instead (see bug#26073): + ;; The behavior of CL made sense in a dynamically scoped + ;; language, but nowadays, lexical scoping semantics is more often + ;; expected. + (`(,(or `let `let*) . ,(or `(,bindings . ,body) dontcare)) + (let ((nbs ()) (found nil)) + (dolist (binding bindings) + (let* ((var (if (symbolp binding) binding (car binding))) + (val (and found (consp binding) (eq 'let* (car exp)) + (list (macroexpand-all (cadr binding) + env))))) + (push (if (assq var venv) + ;; This binding should hide its symbol-macro, + ;; but given the way macroexpand-all works + ;; (i.e. the `env' we receive as input will be + ;; (re)applied to the code we return), we can't + ;; prevent application of `env' to the + ;; sub-expressions, so we need to α-rename this + ;; variable instead. + (let ((nvar (make-symbol (symbol-name var)))) + (setq found t) + (push (list var nvar) venv) + (push (cons :cl-symbol-macros venv) env) + (cons nvar (or val (cdr-safe binding)))) + (if val (cons var val) binding)) + nbs))) + (when found + (setq exp `(,(car exp) + ,(nreverse nbs) + ,@(macroexp-unprogn + (macroexpand-all (macroexp-progn body) + env))))) + nil)) ))) exp)) @@ -2425,10 +2464,11 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'. (pcase-let ((`(,vold ,_getter ,setter ,_vnew) x)) (funcall setter vold))) binds)))) - (let ((binding (car bindings))) - (gv-letplace (getter setter) (car binding) + (let* ((binding (car bindings)) + (place (macroexpand (car binding) macroexpand-all-environment))) + (gv-letplace (getter setter) place (macroexp-let2 nil vnew (cadr binding) - (if (symbolp (car binding)) + (if (symbolp place) ;; Special-case for simple variables. (cl--letf (cdr bindings) (cons `(,getter ,(if (cdr binding) vnew getter)) @@ -2455,7 +2495,9 @@ the PLACE is not modified before executing BODY. (declare (indent 1) (debug ((&rest [&or (symbolp form) (gate gv-place &optional form)]) body))) - (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings))) + (if (and (not (cdr bindings)) (cdar bindings) (symbolp (caar bindings)) + (not (assq (caar bindings) + (alist-get :cl-symbol-macros macroexpand-all-environment)))) `(let ,bindings ,@body) (cl--letf bindings () () body))) diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index de41d826713..78cd6f9d9e5 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -269,12 +269,13 @@ Output is further controlled by the variables `cl-print-readably', `cl-print-compiled', along with output variables for the standard printing functions. See Info node `(elisp)Output Variables'." - (cond - (cl-print-readably (prin1 object stream)) - ((not print-circle) (cl-print-object object stream)) - (t - (let ((cl-print--number-table (cl-print--preprocess object))) - (cl-print-object object stream))))) + (if cl-print-readably + (prin1 object stream) + (with-demoted-errors "cl-prin1: %S" + (if (not print-circle) + (cl-print-object object stream) + (let ((cl-print--number-table (cl-print--preprocess object))) + (cl-print-object object stream)))))) ;;;###autoload (defun cl-prin1-to-string (object) diff --git a/lisp/emacs-lisp/copyright.el b/lisp/emacs-lisp/copyright.el index 69c5ebd45d6..2f29c196964 100644 --- a/lisp/emacs-lisp/copyright.el +++ b/lisp/emacs-lisp/copyright.el @@ -186,9 +186,10 @@ skips to the end of all the years." (substring copyright-current-year -2)) (if (or noquery (save-window-excursion - (switch-to-buffer (current-buffer)) - ;; Fixes some point-moving oddness (bug#2209). + ;; switch-to-buffer might move point when + ;; switch-to-buffer-preserve-window-point is non-nil. (save-excursion + (switch-to-buffer (current-buffer)) (y-or-n-p (if replace (concat "Replace copyright year(s) by " copyright-current-year "? ") diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 593fab97275..4624da30267 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -273,6 +273,12 @@ first will be printed into the backtrace buffer." (setq debug-on-next-call debugger-step-after-exit) debugger-value))) +(defun debugger--print (obj &optional stream) + (condition-case err + (funcall debugger-print-function obj stream) + (error + (message "Error in debug printer: %S" err) + (prin1 obj stream)))) (defun debugger-insert-backtrace (frames do-xrefs) "Format and insert the backtrace FRAMES at point. @@ -287,10 +293,10 @@ Make functions into cross-reference buttons if DO-XREFS is non-nil." (fun-pt (point))) (cond ((and evald (not debugger-stack-frame-as-list)) - (funcall debugger-print-function fun) - (if args (funcall debugger-print-function args) (princ "()"))) + (debugger--print fun) + (if args (debugger--print args) (princ "()"))) (t - (funcall debugger-print-function (cons fun args)) + (debugger--print (cons fun args)) (cl-incf fun-pt))) (when fun-file (make-text-button fun-pt (+ fun-pt (length (symbol-name fun))) @@ -336,7 +342,7 @@ That buffer should be current already." (insert "--returning value: ") (setq pos (point)) (setq debugger-value (nth 1 args)) - (funcall debugger-print-function debugger-value (current-buffer)) + (debugger--print debugger-value (current-buffer)) (setf (cl-getf (nth 3 (car frames)) :debug-on-exit) nil) (insert ?\n)) ;; Watchpoint triggered. @@ -361,7 +367,7 @@ That buffer should be current already." (`error (insert "--Lisp error: ") (setq pos (point)) - (funcall debugger-print-function (nth 1 args) (current-buffer)) + (debugger--print (nth 1 args) (current-buffer)) (insert ?\n)) ;; debug-on-call, when the next thing is an eval. (`t @@ -371,7 +377,7 @@ That buffer should be current already." (_ (insert ": ") (setq pos (point)) - (funcall debugger-print-function + (debugger--print (if (eq (car args) 'nil) (cdr args) args) (current-buffer)) @@ -417,7 +423,7 @@ will be used, such as in a debug on exit from a frame." "from an error" "at function entrance"))) (setq debugger-value val) (princ "Returning " t) - (prin1 debugger-value) + (debugger--print debugger-value) (save-excursion ;; Check to see if we've flagged some frame for debug-on-exit, in which ;; case we'll probably come back to the debugger soon. @@ -532,7 +538,7 @@ The environment used is the one when entering the activation frame at point." (debugger-env-macro (let ((val (backtrace-eval exp nframe base))) (prog1 - (prin1 val t) + (debugger--print val t) (let ((str (eval-expression-print-format val))) (if str (princ str t)))))))) @@ -554,7 +560,7 @@ The environment used is the one when entering the activation frame at point." (insert "\n ") (prin1 symbol (current-buffer)) (insert " = ") - (prin1 value (current-buffer)))))))) + (debugger--print value (current-buffer)))))))) (defun debugger--show-locals () "For the frame at point, insert locals and add text properties." diff --git a/lisp/emacs-lisp/derived.el b/lisp/emacs-lisp/derived.el index 55fa439ad38..547f5cd805b 100644 --- a/lisp/emacs-lisp/derived.el +++ b/lisp/emacs-lisp/derived.el @@ -281,12 +281,10 @@ No problems result if this variable is not bound. ; Splice in the body (if any). ,@body ) - ;; Run the hooks, if any. - (run-mode-hooks ',hook) - ,@(when after-hook - `((if delay-mode-hooks - (push (lambda () ,after-hook) delayed-after-hook-functions) - ,after-hook))))))) + ,@(when after-hook + `((push (lambda () ,after-hook) delayed-after-hook-functions))) + ;; Run the hooks (and delayed-after-hook-functions), if any. + (run-mode-hooks ',hook))))) ;; PUBLIC: find the ultimate class of a derived mode. diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 21ca69324ed..a81b6fefb20 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -545,6 +545,7 @@ Valid keywords and arguments are: "Define a constant M whose value is the result of `easy-mmode-define-keymap'. The M, BS, and ARGS arguments are as per that function. DOC is the constant's documentation." + (declare (indent 1)) `(defconst ,m (easy-mmode-define-keymap ,bs nil (if (boundp ',m) ,m) ,(cons 'list args)) ,doc)) @@ -571,6 +572,7 @@ the constant's documentation." (defmacro easy-mmode-defsyntax (st css doc &rest args) "Define variable ST as a syntax-table. CSS contains a list of syntax specifications of the form (CHAR . SYNTAX)." + (declare (indent 1)) `(progn (autoload 'easy-mmode-define-syntax "easy-mmode") (defconst ,st (easy-mmode-define-syntax ,css ,(cons 'list args)) ,doc))) diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 08e2b978ec7..a0b42086308 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -1066,6 +1066,32 @@ circular objects. Let `read' read everything else." (defvar edebug-error-point nil) (defvar edebug-best-error nil) +;; Functions which may be used to extend Edebug's functionality. See +;; Testcover for an example. +(defvar edebug-after-instrumentation-function #'identity + "Function to run on code after instrumentation for debugging. +The function is called with one argument, a FORM which has just +been instrumented for Edebugging, and it should return either FORM +or a replacement form to use in its place.") + +(defvar edebug-new-definition-function #'edebug-new-definition + "Function to call after Edebug wraps a new definition. +After Edebug has initialized its own data, this function is +called with one argument, the symbol associated with the +definition, which may be the actual symbol defined or one +generated by Edebug.") + +(defvar edebug-behavior-alist + '((edebug edebug-default-enter edebug-slow-before edebug-slow-after)) + "Alist describing the runtime behavior of Edebug's instrumented code. +Each definition instrumented by Edebug will have a +`edebug-behavior' property which is a key to this alist. When +the instrumented code is running, Edebug will look here for the +implementations of `edebug-enter', `edebug-before', and +`edebug-after'. Edebug's instrumentation may be used for a new +purpose by adding an entry to this alist, and setting +`edebug-new-definition-function' to a function which sets +`edebug-behavior' for the definition.") (defun edebug-read-and-maybe-wrap-form () ;; Read a form and wrap it with edebug calls, if the conditions are right. @@ -1125,47 +1151,47 @@ circular objects. Let `read' read everything else." (eq 'symbol (edebug-next-token-class))) (read (current-buffer)))))) ;;;(message "all defs: %s all forms: %s" edebug-all-defs edebug-all-forms) - (cond - (defining-form-p - (if (or edebug-all-defs edebug-all-forms) - ;; If it is a defining form and we are edebugging defs, - ;; then let edebug-list-form start it. - (let ((cursor (edebug-new-cursor - (list (edebug-read-storing-offsets (current-buffer))) - (list edebug-offsets)))) - (car - (edebug-make-form-wrapper - cursor - (edebug-before-offset cursor) - (1- (edebug-after-offset cursor)) - (list (cons (symbol-name def-kind) (cdr spec)))))) - - ;; 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. - (put def-name 'edebug (point-marker)) - ;; Also nil out dependent defs. - '(mapcar (function - (lambda (def) - (put def-name 'edebug nil))) - (get def-name 'edebug-dependents)) - (edebug-read-sexp))) - - ;; If all forms are being edebugged, explicitly wrap it. - (edebug-all-forms - (let ((cursor (edebug-new-cursor - (list (edebug-read-storing-offsets (current-buffer))) - (list edebug-offsets)))) - (edebug-make-form-wrapper - cursor - (edebug-before-offset cursor) - (edebug-after-offset cursor) - nil))) - - ;; Not a defining form, and not edebugging. - (t (edebug-read-sexp))) - )) - + (let ((result + (cond + (defining-form-p + (if (or edebug-all-defs edebug-all-forms) + ;; If it is a defining form and we are edebugging defs, + ;; then let edebug-list-form start it. + (let ((cursor (edebug-new-cursor + (list (edebug-read-storing-offsets (current-buffer))) + (list edebug-offsets)))) + (car + (edebug-make-form-wrapper + cursor + (edebug-before-offset cursor) + (1- (edebug-after-offset cursor)) + (list (cons (symbol-name def-kind) (cdr spec)))))) + + ;; 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. + (put def-name 'edebug (point-marker)) + ;; Also nil out dependent defs. + '(mapcar (function + (lambda (def) + (put def-name 'edebug nil))) + (get def-name 'edebug-dependents)) + (edebug-read-sexp))) + + ;; If all forms are being edebugged, explicitly wrap it. + (edebug-all-forms + (let ((cursor (edebug-new-cursor + (list (edebug-read-storing-offsets (current-buffer))) + (list edebug-offsets)))) + (edebug-make-form-wrapper + cursor + (edebug-before-offset cursor) + (edebug-after-offset cursor) + nil))) + + ;; Not a defining form, and not edebugging. + (t (edebug-read-sexp))))) + (funcall edebug-after-instrumentation-function result)))) (defvar edebug-def-args) ; args of defining form. (defvar edebug-def-interactive) ; is it an emacs interactive function? @@ -1333,7 +1359,6 @@ expressions; a `progn' form will be returned enclosing these forms." ;; (message "defining: %s" edebug-def-name) (sit-for 2) (edebug-make-top-form-data-entry form-data-entry) - (message "Edebug: %s" edebug-def-name) ;;(debug edebug-def-name) ;; Destructively reverse edebug-offset-list and make vector from it. @@ -1359,9 +1384,16 @@ expressions; a `progn' form will be returned enclosing these forms." edebug-offset-list edebug-top-window-data )) + + (funcall edebug-new-definition-function edebug-def-name) result ))) +(defun edebug-new-definition (def-name) + "Set up DEF-NAME to use Edebug's instrumentation functions." + (put def-name 'edebug-behavior 'edebug) + (message "Edebug: %s" def-name)) + (defun edebug-clear-frequency-count (name) ;; Create initial frequency count vector. @@ -2181,7 +2213,21 @@ error is signaled again." ;;; Entering Edebug -(defun edebug-enter (function args body) +(defun edebug-enter (func args body) + "Enter Edebug for a function. +FUNC should be the symbol with the Edebug information, ARGS is +the list of arguments and BODY is the code. + +Look up the `edebug-behavior' for FUNC in `edebug-behavior-alist' +and run its entry function, and set up `edebug-before' and +`edebug-after'." + (cl-letf* ((behavior (get func 'edebug-behavior)) + (functions (cdr (assoc behavior edebug-behavior-alist))) + ((symbol-function #'edebug-before) (nth 1 functions)) + ((symbol-function #'edebug-after) (nth 2 functions))) + (funcall (nth 0 functions) func args body))) + +(defun edebug-default-enter (function args body) ;; Entering FUNC. The arguments are ARGS, and the body is BODY. ;; Setup edebug variables and evaluate BODY. This function is called ;; when a function evaluated with edebug-eval-top-level-form is entered. @@ -2212,7 +2258,7 @@ error is signaled again." edebug-initial-mode edebug-execution-mode) edebug-next-execution-mode nil) - (edebug-enter function args body)))) + (edebug-default-enter function args body)))) (let* ((edebug-data (get function 'edebug)) (edebug-def-mark (car edebug-data)) ; mark at def start @@ -2331,22 +2377,27 @@ MSG is printed after `::::} '." value (edebug-debugger after-index 'after value) ))) - (defun edebug-fast-after (_before-index _after-index value) ;; Do nothing but return the value. value) (defun edebug-run-slow () - (defalias 'edebug-before 'edebug-slow-before) - (defalias 'edebug-after 'edebug-slow-after)) + "Set up Edebug's normal behavior." + (setf (cdr (assq 'edebug edebug-behavior-alist)) + '(edebug-default-enter edebug-slow-before edebug-slow-after))) ;; This is not used, yet. (defun edebug-run-fast () - (defalias 'edebug-before 'edebug-fast-before) - (defalias 'edebug-after 'edebug-fast-after)) - -(edebug-run-slow) - + "Disable Edebug without de-instrumenting code." + (setf (cdr (assq 'edebug edebug-behavior-alist)) + '(edebug-default-enter edebug-fast-before edebug-fast-after))) + +(defalias 'edebug-before nil + "Function called by Edebug before a form is evaluated. +See `edebug-behavior-alist' for implementations.") +(defalias 'edebug-after nil + "Function called by Edebug after a form is evaluated. +See `edebug-behavior-alist' for implementations.") (defun edebug--update-coverage (after-index value) (let ((old-result (aref edebug-coverage after-index))) diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index f0fed17b7da..c0ad7ac4605 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -487,7 +487,7 @@ instance." (cl-defmethod eieio-object-name-string ((obj eieio-named)) "Return a string which is OBJ's name." (or (slot-value obj 'object-name) - (symbol-name (eieio-object-class obj)))) + (cl-call-next-method))) (cl-defmethod eieio-object-set-name-string ((obj eieio-named) name) "Set the string which is OBJ's NAME." diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 78275acd9c2..de08e37286b 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -377,9 +377,21 @@ is a shorthand for (NAME NAME)." (define-obsolete-function-alias 'object-class-fast #'eieio-object-class "24.4") +;; In the past, every EIEIO object had a `name' field, so we had the +;; two methods `eieio-object-name-string' and +;; `eieio-object-set-name-string' "for free". Since this field is +;; very rarely used, we got rid of it and instead we keep it in a weak +;; hash-tables, for those very rare objects that use it. +;; Really, those rare objects should inherit from `eieio-named' instead! +(defconst eieio--object-names (make-hash-table :test #'eq :weakness 'key)) + (cl-defgeneric eieio-object-name-string (obj) "Return a string which is OBJ's name." - (declare (obsolete eieio-named "25.1"))) + (or (gethash obj eieio--object-names) + (format "%s-%x" (eieio-object-class obj) (sxhash-eq obj)))) + +(define-obsolete-function-alias + 'object-name-string #'eieio-object-name-string "24.4") (defun eieio-object-name (obj &optional extra) "Return a printed representation for object OBJ. @@ -389,21 +401,9 @@ If EXTRA, include that in the string returned to represent the symbol." (eieio-object-name-string obj) (or extra ""))) (define-obsolete-function-alias 'object-name #'eieio-object-name "24.4") -(defconst eieio--object-names (make-hash-table :test #'eq :weakness 'key)) - -;; In the past, every EIEIO object had a `name' field, so we had the two method -;; below "for free". Since this field is very rarely used, we got rid of it -;; and instead we keep it in a weak hash-tables, for those very rare objects -;; that use it. -(cl-defmethod eieio-object-name-string (obj) - (or (gethash obj eieio--object-names) - (symbol-name (eieio-object-class obj)))) -(define-obsolete-function-alias - 'object-name-string #'eieio-object-name-string "24.4") - -(cl-defmethod eieio-object-set-name-string (obj name) +(cl-defgeneric eieio-object-set-name-string (obj name) "Set the string which is OBJ's NAME." - (declare (obsolete eieio-named "25.1")) + (declare (obsolete "inherit from `eieio-named' and use (setf (slot-value OBJ 'object-name) NAME) instead" "25.1")) (cl-check-type name string) (setf (gethash obj eieio--object-names) name)) (define-obsolete-function-alias @@ -847,7 +847,16 @@ to prepend a space." (princ (object-print object) stream)) (defvar eieio-print-depth 0 - "When printing, keep track of the current indentation depth.") + "The current indentation depth while printing. +Ignored if `eieio-print-indentation' is nil.") + +(defvar eieio-print-indentation t + "When non-nil, indent contents of printed objects.") + +(defvar eieio-print-object-name t + "When non-nil write the object name in `object-write'. +Does not affect objects subclassing `eieio-named'. Note that +Emacs<26 requires that object names be present.") (cl-defgeneric object-write (this &optional comment) "Write out object THIS to the current stream. @@ -859,10 +868,11 @@ This writes out the vector version of this object. Complex and recursive object are discouraged from being written. If optional COMMENT is non-nil, include comments when outputting this object." - (when comment + (when (and comment eieio-print-object-name) (princ ";; Object ") (princ (eieio-object-name-string this)) - (princ "\n") + (princ "\n")) + (when comment (princ comment) (princ "\n")) (let* ((cl (eieio-object-class this)) @@ -871,12 +881,14 @@ this object." ;; It should look like this: ;; (<constructor> <name> <slot> <slot> ... ) ;; Each slot's slot is writen using its :writer. - (princ (make-string (* eieio-print-depth 2) ? )) + (when eieio-print-indentation + (princ (make-string (* eieio-print-depth 2) ? ))) (princ "(") (princ (symbol-name (eieio--class-constructor (eieio-object-class this)))) - (princ " ") - (prin1 (eieio-object-name-string this)) - (princ "\n") + (when eieio-print-object-name + (princ " ") + (prin1 (eieio-object-name-string this)) + (princ "\n")) ;; Loop over all the public slots (let ((slots (eieio--class-slots cv)) (eieio-print-depth (1+ eieio-print-depth))) @@ -889,7 +901,8 @@ this object." (unless (or (not i) (equal v (cl--slot-descriptor-initform slot))) (unless (bolp) (princ "\n")) - (princ (make-string (* eieio-print-depth 2) ? )) + (when eieio-print-indentation + (princ (make-string (* eieio-print-depth 2) ? ))) (princ (symbol-name i)) (if (alist-get :printer (cl--slot-descriptor-props slot)) ;; Use our public printer @@ -904,7 +917,7 @@ this object." "\n" " ")) (eieio-override-prin1 v)))))))) (princ ")") - (when (= eieio-print-depth 0) + (when (zerop eieio-print-depth) (princ "\n")))) (defun eieio-override-prin1 (thing) @@ -942,14 +955,16 @@ this object." (progn (princ "'") (prin1 list)) - (princ (make-string (* eieio-print-depth 2) ? )) + (when eieio-print-indentation + (princ (make-string (* eieio-print-depth 2) ? ))) (princ "(list") (let ((eieio-print-depth (1+ eieio-print-depth))) (while list (princ "\n") (if (eieio-object-p (car list)) (object-write (car list)) - (princ (make-string (* eieio-print-depth 2) ? )) + (when eieio-print-indentation + (princ (make-string (* eieio-print-depth) ? ))) (eieio-override-prin1 (car list))) (setq list (cdr list)))) (princ ")"))) diff --git a/lisp/emacs-lisp/elint.el b/lisp/emacs-lisp/elint.el index b89290ad524..eae0dacfd23 100644 --- a/lisp/emacs-lisp/elint.el +++ b/lisp/emacs-lisp/elint.el @@ -463,21 +463,9 @@ Return nil if there are no more forms, t otherwise." ;; Import variable definitions ((memq (car form) '(require cc-require cc-require-when-compile)) (let ((name (eval (cadr form))) - (file (eval (nth 2 form))) - (elint-doing-cl (bound-and-true-p elint-doing-cl))) + (file (eval (nth 2 form)))) (unless (memq name elint-features) (add-to-list 'elint-features name) - ;; cl loads cl-macs in an opaque manner. - ;; Since cl-macs requires cl, we can just process cl-macs. - ;; FIXME: AFAIK, `cl' now behaves properly and does not need any - ;; special treatment any more. Can someone who understands this - ;; code confirm? --Stef - (and (eq name 'cl) (not elint-doing-cl) - ;; We need cl if elint-form is to be able to expand cl macros. - (require 'cl) - (setq name 'cl-macs - file nil - elint-doing-cl t)) ; blech (setq elint-env (elint-add-required-env elint-env name file)))))) elint-env) diff --git a/lisp/emacs-lisp/elp.el b/lisp/emacs-lisp/elp.el index dab17fd75b6..2dc18163aa3 100644 --- a/lisp/emacs-lisp/elp.el +++ b/lisp/emacs-lisp/elp.el @@ -382,14 +382,13 @@ original definition, use \\[elp-restore-function] or \\[elp-restore-all]." ;; and return the results. (setq result (apply func args)) ;; we are recording times - (let (enter-time exit-time) + (let (enter-time) ;; increment the call-counter (cl-incf (aref info 0)) (setq enter-time (current-time) - result (apply func args) - exit-time (current-time)) + result (apply func args)) ;; calculate total time in function - (cl-incf (aref info 1) (elp-elapsed-time enter-time exit-time)) + (cl-incf (aref info 1) (elp-elapsed-time enter-time nil)) )) ;; turn off recording if this is the master function (if (and elp-master diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 15d488f7101..029a2939a0b 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -1333,6 +1333,9 @@ RESULT must be an `ert-test-result-with-condition'." ;;; Running tests in batch mode. +(defvar ert-quiet nil + "Non-nil makes ERT only print important information in batch mode.") + ;;;###autoload (defun ert-run-tests-batch (&optional selector) "Run the tests specified by SELECTOR, printing results to the terminal. @@ -1349,10 +1352,11 @@ Returns the stats object." (lambda (event-type &rest event-args) (cl-ecase event-type (run-started - (cl-destructuring-bind (stats) event-args - (message "Running %s tests (%s)" - (length (ert--stats-tests stats)) - (ert--format-time-iso8601 (ert--stats-start-time stats))))) + (unless ert-quiet + (cl-destructuring-bind (stats) event-args + (message "Running %s tests (%s)" + (length (ert--stats-tests stats)) + (ert--format-time-iso8601 (ert--stats-start-time stats)))))) (run-ended (cl-destructuring-bind (stats abortedp) event-args (let ((unexpected (ert-stats-completed-unexpected stats)) @@ -1438,16 +1442,17 @@ Returns the stats object." (ert-test-name test))) (ert-test-quit (message "Quit during %S" (ert-test-name test))))) - (let* ((max (prin1-to-string (length (ert--stats-tests stats)))) - (format-string (concat "%9s %" - (prin1-to-string (length max)) - "s/" max " %S"))) - (message format-string - (ert-string-for-test-result result - (ert-test-result-expected-p - test result)) - (1+ (ert--stats-test-pos stats test)) - (ert-test-name test))))))) + (unless ert-quiet + (let* ((max (prin1-to-string (length (ert--stats-tests stats)))) + (format-string (concat "%9s %" + (prin1-to-string (length max)) + "s/" max " %S"))) + (message format-string + (ert-string-for-test-result result + (ert-test-result-expected-p + test result)) + (1+ (ert--stats-test-pos stats test)) + (ert-test-name test)))))))) nil)) ;;;###autoload diff --git a/lisp/emacs-lisp/faceup.el b/lisp/emacs-lisp/faceup.el new file mode 100644 index 00000000000..bbf4c5da7e5 --- /dev/null +++ b/lisp/emacs-lisp/faceup.el @@ -0,0 +1,1180 @@ +;;; faceup.el --- Markup language for faces and font-lock regression testing -*- lexical-binding: t -*- + +;; Copyright (C) 2013-2018 Free Software Foundation, Inc. + +;; Author: Anders Lindgren +;; Version: 0.0.6 +;; Created: 2013-01-21 +;; Keywords: faces languages +;; URL: https://github.com/Lindydancer/faceup + +;; 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: + +;; Emacs is capable of highlighting buffers based on language-specific +;; `font-lock' rules. This package makes it possible to perform +;; regression test for packages that provide font-lock rules. +;; +;; The underlying idea is to convert text with highlights ("faces") +;; into a plain text representation using the Faceup markup +;; language. This language is semi-human readable, for example: +;; +;; «k:this» is a keyword +;; +;; By comparing the current highlight with a highlight performed with +;; stable versions of a package, it's possible to automatically find +;; problems that otherwise would have been hard to spot. +;; +;; This package is designed to be used in conjunction with Ert, the +;; standard Emacs regression test system. +;; +;; The Faceup markup language is a generic markup language, regression +;; testing is merely one way to use it. + +;; Regression test examples: +;; +;; This section describes the two typical ways regression testing with +;; this package is performed. +;; +;; +;; Full source file highlighting: +;; +;; The most straight-forward way to perform regression testing is to +;; collect a number of representative source files. From each source +;; file, say `alpha.mylang', you can use `M-x faceup-write-file RET' +;; to generate a Faceup file named `alpha.mylang.faceup', this file +;; use the Faceup markup language to represent the text with +;; highlights and is used as a reference in future tests. +;; +;; An Ert test case can be defined as follows: +;; +;; (require 'faceup) +;; +;; (defvar mylang-font-lock-test-dir (faceup-this-file-directory)) +;; +;; (defun mylang-font-lock-test-apps (file) +;; "Test that the mylang FILE is fontifies as the .faceup file describes." +;; (faceup-test-font-lock-file 'mylang-mode +;; (concat mylang-font-lock-test-dir file))) +;; (faceup-defexplainer mylang-font-lock-test-apps) +;; +;; (ert-deftest mylang-font-lock-file-test () +;; (should (mylang-font-lock-test-apps "apps/FirstApp/alpha.mylang")) +;; ;; ... Add more test files here ... +;; ) +;; +;; To execute the tests, run something like `M-x ert RET t RET'. +;; +;; +;; Source snippets: +;; +;; To test smaller snippets of code, you can use the +;; `faceup-test-font-lock-string'. It takes a major mode and a string +;; written using the Faceup markup language. The functions strips away +;; the Faceup markup, inserts the plain text into a temporary buffer, +;; highlights it, converts the result back into the Faceup markup +;; language, and finally compares the result with the original Faceup +;; string. +;; +;; For example: +;; +;; (defun mylang-font-lock-test (faceup) +;; (faceup-test-font-lock-string 'mylang-mode faceup)) +;; (faceup-defexplainer mylang-font-lock-test) +;; +;; (ert-deftest mylang-font-lock-test-simple () +;; "Simple MyLang font-lock tests." +;; (should (mylang-font-lock-test "«k:this» is a keyword")) +;; (should (mylang-font-lock-test "«k:function» «f:myfunc» («v:var»)"))) +;; + +;; Executing the tests: +;; +;; Once the tests have been defined, you can use `M-x ert RET t RET' +;; to execute them. Hopefully, you will be given the "all clear". +;; However, if there is a problem, you will be presented with +;; something like: +;; +;; F mylang-font-lock-file-test +;; (ert-test-failed +;; ((should +;; (mylang-font-lock-test-apps "apps/FirstApp/alpha.mylang")) +;; :form +;; (mylang-font-lock-test-apps "apps/FirstApp/alpha.mylang") +;; :value nil :explanation +;; ((on-line 2 +;; ("but_«k:this»_is_not_a_keyword") +;; ("but_this_is_not_a_keyword"))))) +;; +;; You should read this that on line 2, the old font-lock rules +;; highlighted `this' inside `but_this_is_not_a_keyword' (which is +;; clearly wrong), whereas the new doesn't. Of course, if this is the +;; desired result (for example, the result of a recent change) you can +;; simply regenerate the .faceup file and store it as the reference +;; file for the future. + +;; The Faceup markup language: +;; +;; The Faceup markup language is designed to be human-readable and +;; minimalistic. +;; +;; The two special characters `«' and `»' marks the start and end of a +;; range of a face. +;; +;; +;; Compact format for special faces: +;; +;; The compact format `«<LETTER>:text»' is used for a number of common +;; faces. For example, `«U:abc»' means that the text `abc' is +;; underlined. +;; +;; See `faceup-face-short-alist' for the known faces and the +;; corresponding letter. +;; +;; +;; Full format: +;; +;; The format `«:<NAME OF FACE>:text»' is used use to encode other +;; faces. +;; +;; For example `«:my-special-face:abc»' meanst that `abc' has the face +;; `my-special-face'. +;; +;; +;; Anonymous faces: +;; +;; An "anonymous face" is when the `face' property contains a property +;; list (plist) on the form `(:key value)'. This is represented using +;; a variant of the full format: `«:(:key value):text»'. +;; +;; For example, `«:(:background "red"):abc»' represent the text `abc' +;; with a red background. +;; +;; +;; Multiple properties: +;; +;; In case a text contains more than one face property, they are +;; represented using nested sections. +;; +;; For example: +;; +;; * `«B:abc«U:def»»' represent the text `abcdef' that is both *bold* +;; and *underlined*. +;; +;; * `«W:abc«U:def»ghi»' represent the text `abcdefghi' where the +;; entire text is in *warning* face and `def' is *underlined*. +;; +;; In case two faces partially overlap, the ranges will be split when +;; represented in Faceup. For example: +;; +;; * `«B:abc«U:def»»«U:ghi»' represent the text `abcdefghi' where +;; `abcdef' is bold and `defghi' is underlined. +;; +;; +;; Escaping start and end markers: +;; +;; Any occurrence of the start or end markers in the original text +;; will be escaped using the start marker in the Faceup +;; representation. In other words, the sequences `««' and `«»' +;; represent a start and end marker, respectively. +;; +;; +;; Other properties: +;; +;; In addition to representing the `face' property (or, more +;; correctly, the value of `faceup-default-property') other properties +;; can be encoded. The variable `faceup-properties' contains a list of +;; properties to track. If a property behaves like the `face' +;; property, it is encoded as described above, with the addition of +;; the property name placed in parentheses, for example: +;; `«(my-face)U:abd»'. +;; +;; The variable `faceup-face-like-properties' contains a list of +;; properties considered face-like. +;; +;; Properties that are not considered face-like are always encoded +;; using the full format and the don't nest. For example: +;; `«(my-fibonacci-property):(1 1 2 3 5 8):abd»'. +;; +;; Examples of properties that could be tracked are: +;; +;; * `font-lock-face' -- an alias to `face' when `font-lock-mode' is +;; enabled. +;; +;; * `syntax-table' -- used by a custom `syntax-propertize' to +;; override the default syntax table. +;; +;; * `help-echo' -- provides tooltip text displayed when the mouse is +;; held over a text. + +;; Reference section: +;; +;; Faceup commands and functions: +;; +;; `M-x faceup-write-file RET' - generate a Faceup file based on the +;; current buffer. +;; +;; `M-x faceup-view-file RET' - view the current buffer converted to +;; Faceup. +;; +;; `faceup-markup-{string,buffer}' - convert text with properties to +;; the Faceup markup language. +;; +;; `faceup-render-view-buffer' - convert buffer with Faceup markup to +;; a buffer with real text properties and display it. +;; +;; `faceup-render-string' - return string with real text properties +;; from a string with Faceup markup. +;; +;; `faceup-render-to-{buffer,string}' - convert buffer with Faceup +;; markup to a buffer/string with real text properties. +;; +;; `faceup-clean-{buffer,string}' - remove Faceup markup from buffer +;; or string. +;; +;; +;; Regression test support: +;; +;; The following functions can be used as Ert test functions, or can +;; be used to implement new Ert test functions. +;; +;; `faceup-test-equal' - Test function, work like Ert:s `equal', but +;; more ergonomically when reporting multi-line string errors. +;; Concretely, it breaks down multi-line strings into lines and +;; reports which line number the error occurred on and the content of +;; that line. +;; +;; `faceup-test-font-lock-buffer' - Test that a buffer is highlighted +;; according to a reference Faceup text, for a specific major mode. +;; +;; `faceup-test-font-lock-string' - Test that a text with Faceup +;; markup is refontified to match the original Faceup markup. +;; +;; `faceup-test-font-lock-file' - Test that a file is highlighted +;; according to a reference .faceup file. +;; +;; `faceup-defexplainer' - Macro, define an explainer function and set +;; the `ert-explainer' property on the original function, for +;; functions based on the above test functions. +;; +;; `faceup-this-file-directory' - Macro, the directory of the current +;; file. + +;; Real-world examples: +;; +;; The following are examples of real-world package that use faceup to +;; test their font-lock keywords. +;; +;; * [cmake-font-lock](https://github.com/Lindydancer/cmake-font-lock) +;; an advanced set of font-lock keywords for the CMake language +;; +;; * [objc-font-lock](https://github.com/Lindydancer/objc-font-lock) +;; highlight Objective-C function calls. +;; + +;; Other Font Lock Tools: +;; +;; This package is part of a suite of font-lock tools. The other +;; tools in the suite are: +;; +;; +;; Font Lock Studio: +;; +;; Interactive debugger for font-lock keywords (Emacs syntax +;; highlighting rules). +;; +;; Font Lock Studio lets you *single-step* Font Lock keywords -- +;; matchers, highlights, and anchored rules, so that you can see what +;; happens when a buffer is fontified. You can set *breakpoints* on +;; or inside rules and *run* until one has been hit. When inside a +;; rule, matches are *visualized* using a palette of background +;; colors. The *explainer* can describe a rule in plain-text English. +;; Tight integration with *Edebug* allows you to step into Lisp +;; expressions that are part of the Font Lock keywords. +;; +;; +;; Font Lock Profiler: +;; +;; A profiler for font-lock keywords. This package measures time and +;; counts the number of times each part of a font-lock keyword is +;; used. For matchers, it counts the total number and the number of +;; successful matches. +;; +;; The result is presented in table that can be sorted by count or +;; time. The table can be expanded to include each part of the +;; font-lock keyword. +;; +;; In addition, this package can generate a log of all font-lock +;; events. This can be used to verify font-lock implementations, +;; concretely, this is used for back-to-back tests of the real +;; font-lock engine and Font Lock Studio, an interactive debugger for +;; font-lock keywords. +;; +;; +;; Highlight Refontification: +;; +;; Minor mode that visualizes how font-lock refontifies a buffer. +;; This is useful when developing or debugging font-lock keywords, +;; especially for keywords that span multiple lines. +;; +;; The background of the buffer is painted in a rainbow of colors, +;; where each band in the rainbow represent a region of the buffer +;; that has been refontified. When the buffer is modified, the +;; rainbow is updated. +;; +;; +;; Face Explorer: +;; +;; Library and tools for faces and text properties. +;; +;; This library is useful for packages that convert syntax highlighted +;; buffers to other formats. The functions can be used to determine +;; how a face or a face text property looks, in terms of primitive +;; face attributes (e.g. foreground and background colors). Two sets +;; of functions are provided, one for existing frames and one for +;; fictitious displays, like 8 color tty. +;; +;; In addition, the following tools are provided: +;; +;; - `face-explorer-list-faces' -- list all available faces. Like +;; `list-faces-display' but with information on how a face is +;; defined. In addition, a sample for the selected frame and for a +;; fictitious display is shown. +;; +;; - `face-explorer-describe-face' -- Print detailed information on +;; how a face is defined, and list all underlying definitions. +;; +;; - `face-explorer-describe-face-prop' -- Describe the `face' text +;; property at the point in terms of primitive face attributes. +;; Also show how it would look on a fictitious display. +;; +;; - `face-explorer-list-display-features' -- Show which features a +;; display supports. Most graphical displays support all, or most, +;; features. However, many tty:s don't support, for example, +;; strike-through. Using specially constructed faces, the resulting +;; buffer will render differently in different displays, e.g. a +;; graphical frame and a tty connected using `emacsclient -nw'. +;; +;; - `face-explorer-list-face-prop-examples' -- Show a buffer with an +;; assortment of `face' text properties. A sample text is shown in +;; four variants: Native, a manually maintained reference vector, +;; the result of `face-explorer-face-prop-attributes' and +;; `face-explorer-face-prop-attributes-for-fictitious-display'. Any +;; package that convert a buffer to another format (like HTML, ANSI, +;; or LaTeX) could use this buffer to ensure that everything work as +;; intended. +;; +;; - `face-explorer-list-overlay-examples' -- Show a buffer with a +;; number of examples of overlays, some are mixed with `face' text +;; properties. Any package that convert a buffer to another format +;; (like HTML, ANSI, or LaTeX) could use this buffer to ensure that +;; everything work as intended. +;; +;; - `face-explorer-tooltip-mode' -- Minor mode that shows tooltips +;; containing text properties and overlays at the mouse pointer. +;; +;; - `face-explorer-simulate-display-mode' -- Minor mode for make a +;; buffer look like it would on a fictitious display. Using this +;; you can, for example, see how a theme would look in using dark or +;; light background, a 8 color tty, or on a grayscale graphical +;; monitor. +;; +;; +;; Font Lock Regression Suite: +;; +;; A collection of example source files for a large number of +;; programming languages, with ERT tests to ensure that syntax +;; highlighting does not accidentally change. +;; +;; For each source file, font-lock reference files are provided for +;; various Emacs versions. The reference files contains a plain-text +;; representation of source file with syntax highlighting, using the +;; format "faceup". +;; +;; Of course, the collection source file can be used for other kinds +;; of testing, not limited to font-lock regression testing. + +;;; Code: + + +(defvar faceup-default-property 'face + "The property that should be represented in Faceup without the (prop) part.") + +(defvar faceup-properties '(face) + "List of properties that should be converted to the Faceup format. + +Only face-like property use the short format. All other use the +non-nesting full format. (See `faceup-face-like-properties'.)" ) + + +(defvar faceup-face-like-properties '(face font-lock-face) + "List of properties that behave like `face'. + +The following properties are assumed about face-like properties: + +* Elements are either symbols or property lists, or lists thereof. + +* A plain element and a list containing the same element are + treated as equal + +* Property lists and sequences of property lists are considered + equal. For example: + + ((:underline t :foreground \"red\")) + + and + + ((:underline t) (:foreground \"red\")) + +Face-like properties are converted to faceup in a nesting fashion. + +For example, the string AAAXXXAAA (where the property `prop' has +the value `(a)' on the A:s and `(a b)' on the X:s) is converted +as follows, when treated as a face-like property: + + «(prop):a:AAA«(prop):b:XXX»AAAA» + +When treated as a non-face-like property: + + «(prop):(a):AAA»«(prop):(a b):XXX»«(prop):(a):AAA»") + + +(defvar faceup-markup-start-char ?«) +(defvar faceup-markup-end-char ?») + +(defvar faceup-face-short-alist + '(;; Generic faces (uppercase letters) + (bold . "B") + (bold-italic . "Q") + (default . "D") + (error . "E") + (highlight . "H") + (italic . "I") + (underline . "U") + (warning . "W") + ;; font-lock-specific faces (lowercase letters) + (font-lock-builtin-face . "b") + (font-lock-comment-delimiter-face . "m") + (font-lock-comment-face . "x") + (font-lock-constant-face . "c") + (font-lock-doc-face . "d") + (font-lock-function-name-face . "f") + (font-lock-keyword-face . "k") + (font-lock-negation-char-face . "n") + (font-lock-preprocessor-face . "p") + (font-lock-regexp-grouping-backslash . "h") + (font-lock-regexp-grouping-construct . "o") + (font-lock-string-face . "s") + (font-lock-type-face . "t") + (font-lock-variable-name-face . "v") + (font-lock-warning-face . "w")) + "Alist from faces to one-character representation.") + + +;; Plain: «W....» +;; Nested: «W...«W...»» + +;; Overlapping: xxxxxxxxxx +;; yyyyyyyyyyyy +;; «X..«Y..»»«Y...» + + +(defun faceup-markup-string (s) + "Return the faceup version of the string S." + (with-temp-buffer + (insert s) + (faceup-markup-buffer))) + + +;;;###autoload +(defun faceup-view-buffer () + "Display the faceup representation of the current buffer." + (interactive) + (let ((buffer (get-buffer-create "*FaceUp*"))) + (with-current-buffer buffer + (delete-region (point-min) (point-max))) + (faceup-markup-to-buffer buffer) + (display-buffer buffer))) + + +;;;###autoload +(defun faceup-write-file (&optional file-name confirm) + "Save the faceup representation of the current buffer to the file FILE-NAME. + +Unless a name is given, the file will be named xxx.faceup, where +xxx is the file name associated with the buffer. + +If optional second arg CONFIRM is non-nil, this function +asks for confirmation before overwriting an existing file. +Interactively, confirmation is required unless you supply a prefix argument." + (interactive + (let ((suggested-name (and (buffer-file-name) + (concat (buffer-file-name) + ".faceup")))) + (list (read-file-name "Write faceup file: " + default-directory + suggested-name + nil + (file-name-nondirectory suggested-name)) + (not current-prefix-arg)))) + (unless file-name + (setq file-name (concat (buffer-file-name) ".faceup"))) + (let ((buffer (current-buffer))) + (with-temp-buffer + (faceup-markup-to-buffer (current-buffer) buffer) + ;; Note: Must set `require-final-newline' inside + ;; `with-temp-buffer', otherwise the value will be overridden by + ;; the buffers local value. + ;; + ;; Clear `window-size-change-functions' as a workaround for + ;; Emacs bug#19576 (`write-file' saves the wrong buffer if a + ;; function in the list change current buffer). + (let ((require-final-newline nil) + (window-size-change-functions '())) + (write-file file-name confirm))))) + + +(defun faceup-markup-buffer () + "Return a string with the content of the buffer using faceup markup." + (let ((buf (current-buffer))) + (with-temp-buffer + (faceup-markup-to-buffer (current-buffer) buf) + (buffer-substring-no-properties (point-min) (point-max))))) + + +;; Idea: +;; +;; Typically, only one face is used. However, when two faces are used, +;; the one of top is typically shorter. Hence, the faceup variant +;; should treat the inner group of nested ranges the upper (i.e. the +;; one towards the front.) For example: +;; +;; «f:aaaaaaa«U:xxxx»aaaaaa» + +(defun faceup-copy-and-quote (start end to-buffer) + "Quote and insert the text between START and END into TO-BUFFER." + (let ((not-markup (concat "^" + (make-string 1 faceup-markup-start-char) + (make-string 1 faceup-markup-end-char)))) + (save-excursion + (goto-char start) + (while (< (point) end) + (let ((old (point))) + (skip-chars-forward not-markup end) + (let ((s (buffer-substring-no-properties old (point)))) + (with-current-buffer to-buffer + (insert s)))) + ;; Quote stray markup characters. + (unless (= (point) end) + (let ((next-char (following-char))) + (with-current-buffer to-buffer + (insert faceup-markup-start-char) + (insert next-char))) + (forward-char)))))) + + +;; A face (string or symbol) can be on the top level. +;; +;; A face text property can be a arbitrary deep lisp structure. Each +;; list in the tree structure contains faces (symbols or strings) up +;; to the first keyword, e.g. :foreground, thereafter the list is +;; considered a property list, regardless of the content. A special +;; case are `(foreground-color . COLOR)' and `(background-color +;; . COLOR)', old forms used to represent the foreground and +;; background colors, respectively. +;; +;; Some of this is undocumented, and took some effort to reverse +;; engineer. +(defun faceup-normalize-face-property (value) + "Normalize VALUES into a list of faces and (KEY VALUE) entries." + (cond ((null value) + '()) + ((symbolp value) + (list value)) + ((stringp value) + (list (intern value))) + ((consp value) + (cond ((eq (car value) 'foreground-color) + (list (list :foreground (cdr value)))) + ((eq (car value) 'background-color) + (list (list :background (cdr value)))) + (t + ;; A list + (if (keywordp (car value)) + ;; Once a keyword has been seen, the rest of the + ;; list is treated as a property list, regardless + ;; of what it contains. + (let ((res '())) + (while value + (let ((key (pop value)) + (val (pop value))) + (when (keywordp key) + (push (list key val) res)))) + res) + (append + (faceup-normalize-face-property (car value)) + (faceup-normalize-face-property (cdr value))))))) + (t + (error "Unexpected text property %s" value)))) + + +(defun faceup-get-text-properties (pos) + "Alist of properties and values at POS. + +Face-like properties are normalized -- value is a list of +faces (symbols) and short (KEY VALUE) lists. The list is +reversed to that later elements take precedence over earlier." + (let ((res '())) + (dolist (prop faceup-properties) + (let ((value (get-text-property pos prop))) + (when value + (when (memq prop faceup-face-like-properties) + ;; Normalize face-like properties. + (setq value (reverse (faceup-normalize-face-property value)))) + (push (cons prop value) res)))) + res)) + + +(defun faceup-markup-to-buffer (to-buffer &optional buffer) + "Convert content of BUFFER to faceup form and insert in TO-BUFFER." + (save-excursion + (if buffer + (set-buffer buffer)) + ;; Font-lock often only fontifies the visible sections. This + ;; ensures that the entire buffer is fontified before converting + ;; it. + (if (and font-lock-mode + ;; Prevent clearing out face attributes explicitly + ;; inserted by functions like `list-faces-display'. + ;; (Font-lock mode is enabled, for some reason, in those + ;; buffers.) + (not (and (eq major-mode 'help-mode) + (not font-lock-defaults)))) + (font-lock-fontify-region (point-min) (point-max))) + (let ((last-pos (point-min)) + (pos nil) + ;; List of (prop . value), representing open faceup blocks. + (state '())) + (while (setq pos (faceup-next-property-change pos)) + ;; Insert content. + (faceup-copy-and-quote last-pos pos to-buffer) + (setq last-pos pos) + (let ((prop-values (faceup-get-text-properties pos))) + (let ((next-state '())) + (setq state (reverse state)) + ;; Find all existing sequences that should continue. + (let ((cont t)) + (while (and state + prop-values + cont) + (let* ((prop (car (car state))) + (value (cdr (car state))) + (pair (assq prop prop-values))) + (if (memq prop faceup-face-like-properties) + ;; Element by element. + (if (equal value (car (cdr pair))) + (setcdr pair (cdr (cdr pair))) + (setq cont nil)) + ;; Full value. + ;; + ;; Note: Comparison is done by `eq', since (at + ;; least) the `display' property treats + ;; eq-identical values differently than when + ;; comparing using `equal'. See "Display Specs + ;; That Replace The Text" in the elisp manual. + (if (eq value (cdr pair)) + (setq prop-values (delq pair prop-values)) + (setq cont nil)))) + (when cont + (push (pop state) next-state)))) + ;; End values that should not be included in the next state. + (while state + (with-current-buffer to-buffer + (insert (make-string 1 faceup-markup-end-char))) + (pop state)) + ;; Start new ranges. + (with-current-buffer to-buffer + (while prop-values + (let ((pair (pop prop-values))) + (if (memq (car pair) faceup-face-like-properties) + ;; Face-like. + (dolist (element (cdr pair)) + (insert (make-string 1 faceup-markup-start-char)) + (unless (eq (car pair) faceup-default-property) + (insert "(") + (insert (symbol-name (car pair))) + (insert "):")) + (if (symbolp element) + (let ((short + (assq element faceup-face-short-alist))) + (if short + (insert (cdr short) ":") + (insert ":" (symbol-name element) ":"))) + (insert ":") + (prin1 element (current-buffer)) + (insert ":")) + (push (cons (car pair) element) next-state)) + ;; Not face-like. + (insert (make-string 1 faceup-markup-start-char)) + (insert "(") + (insert (symbol-name (car pair))) + (insert "):") + (prin1 (cdr pair) (current-buffer)) + (insert ":") + (push pair next-state))))) + ;; Insert content. + (setq state next-state)))) + ;; Insert whatever is left after the last face change. + (faceup-copy-and-quote last-pos (point-max) to-buffer)))) + + + +;; Some basic facts: +;; +;; (get-text-property (point-max) ...) always return nil. To check the +;; last character in the buffer, use (- (point-max) 1). +;; +;; If a text has more than one face, the first one in the list +;; takes precedence, when being viewed in Emacs. +;; +;; (let ((s "ABCDEF")) +;; (set-text-properties 1 4 +;; '(face (font-lock-warning-face font-lock-variable-name-face)) s) +;; (insert s)) +;; +;; => ABCDEF +;; +;; Where DEF is drawn in "warning" face. + + +(defun faceup-has-any-text-property (pos) + "True if any properties in `faceup-properties' are defined at POS." + (let ((res nil)) + (dolist (prop faceup-properties) + (when (get-text-property pos prop) + (setq res t))) + res)) + + +(defun faceup-next-single-property-change (pos) + "Next position a property in `faceup-properties' changes after POS, or nil." + (let ((res nil)) + (dolist (prop faceup-properties) + (let ((next (next-single-property-change pos prop))) + (when next + (setq res (if res + (min res next) + next))))) + res)) + + +(defun faceup-next-property-change (pos) + "Next position after POS where one of the tracked properties change. + +If POS is nil, also include `point-min' in the search. +If last character contains a tracked property, return `point-max'. + +See `faceup-properties' for a list of tracked properties." + (if (eq pos (point-max)) + ;; Last search returned `point-max'. There is no more to search + ;; for. + nil + (if (and (null pos) + (faceup-has-any-text-property (point-min))) + ;; `pos' is `nil' and the character at `point-min' contains a + ;; tracked property, return `point-min'. + (point-min) + (unless pos + ;; Start from the beginning. + (setq pos (point-min))) + ;; Do a normal search. Compensate for that + ;; `next-single-property-change' does not include the end of the + ;; buffer, even when a property reach it. + (let ((res (faceup-next-single-property-change pos))) + (if (and (not res) ; No more found. + (not (eq pos (point-max))) ; Not already at the end. + (not (eq (point-min) (point-max))) ; Not an empty buffer. + (faceup-has-any-text-property (- (point-max) 1))) + ;; If a property goes all the way to the end of the + ;; buffer, return `point-max'. + (point-max) + res))))) + + +;; ---------------------------------------------------------------------- +;; Renderer +;; + +;; Functions to convert from the faceup textual representation to text +;; with real properties. + +(defun faceup-render-string (faceup) + "Return string with properties from FACEUP written with Faceup markup." + (with-temp-buffer + (insert faceup) + (faceup-render-to-string))) + + +;;;###autoload +(defun faceup-render-view-buffer (&optional buffer) + "Convert BUFFER containing Faceup markup to a new buffer and display it." + (interactive) + (with-current-buffer (or buffer (current-buffer)) + (let ((dest-buffer (get-buffer-create "*FaceUp rendering*"))) + (with-current-buffer dest-buffer + (delete-region (point-min) (point-max))) + (faceup-render-to-buffer dest-buffer) + (display-buffer dest-buffer)))) + + +(defun faceup-render-to-string (&optional buffer) + "Convert BUFFER containing faceup markup to a string with faces." + (unless buffer + (setq buffer (current-buffer))) + (with-temp-buffer + (faceup-render-to-buffer (current-buffer) buffer) + (buffer-substring (point-min) (point-max)))) + + +(defun faceup-render-to-buffer (to-buffer &optional buffer) + "Convert BUFFER containing faceup markup into text with faces in TO-BUFFER." + (with-current-buffer (or buffer (current-buffer)) + (goto-char (point-min)) + (let ((last-point (point)) + (state '()) ; List of (prop . element) + (not-markup (concat + "^" + (make-string 1 faceup-markup-start-char) + (make-string 1 faceup-markup-end-char)))) + (while (progn + (skip-chars-forward not-markup) + (if (not (eq last-point (point))) + (let ((text (buffer-substring-no-properties + last-point (point))) + (prop-elements-alist '())) + ;; Accumulate all values for each property. + (dolist (prop-element state) + (let ((property (car prop-element)) + (element (cdr prop-element))) + (let ((pair (assq property prop-elements-alist))) + (unless pair + (setq pair (cons property '())) + (push pair prop-elements-alist)) + (push element (cdr pair))))) + ;; Apply all properties. + (dolist (pair prop-elements-alist) + (let ((property (car pair)) + (elements (reverse (cdr pair)))) + ;; Create one of: + ;; (property element) or + ;; (property (element element ...)) + (when (eq (length elements) 1) + ;; This ensures that non-face-like + ;; properties are restored to their + ;; original state. + (setq elements (car elements))) + (add-text-properties 0 (length text) + (list property elements) + text))) + (with-current-buffer to-buffer + (insert text)) + (setq last-point (point)))) + (not (eobp))) + (if (eq (following-char) faceup-markup-start-char) + ;; Start marker. + (progn + (forward-char) + (if (or (eq (following-char) faceup-markup-start-char) + (eq (following-char) faceup-markup-end-char)) + ;; Escaped markup character. + (progn + (setq last-point (point)) + (forward-char)) + ;; Markup sequence. + (let ((property faceup-default-property)) + (when (eq (following-char) ?\( ) + (forward-char) ; "(" + (let ((p (point))) + (forward-sexp) + (setq property (intern (buffer-substring p (point))))) + (forward-char)) ; ")" + (let ((element + (if (eq (following-char) ?:) + ;; :element: + (progn + (forward-char) + (prog1 + (let ((p (point))) + (forward-sexp) + ;; Note: (read (current-buffer)) + ;; doesn't work, as it reads more + ;; than a sexp. + (read (buffer-substring p (point)))) + (forward-char))) + ;; X: + (prog1 + (car (rassoc (buffer-substring-no-properties + (point) (+ (point) 1)) + faceup-face-short-alist)) + (forward-char 2))))) + (push (cons property element) state))) + (setq last-point (point)))) + ;; End marker. + (pop state) + (forward-char) + (setq last-point (point))))))) + +;; ---------------------------------------------------------------------- + +;;;###autoload +(defun faceup-clean-buffer () + "Remove faceup markup from buffer." + (interactive) + (goto-char (point-min)) + (let ((not-markup (concat + "^" + (make-string 1 faceup-markup-start-char) + (make-string 1 faceup-markup-end-char)))) + (while (progn (skip-chars-forward not-markup) + (not (eobp))) + (if (eq (following-char) faceup-markup-end-char) + ;; End markers are always on their own. + (delete-char 1) + ;; Start marker. + (delete-char 1) + (if (or (eq (following-char) faceup-markup-start-char) + (eq (following-char) faceup-markup-end-char)) + ;; Escaped markup character, delete the escape and skip + ;; the original character. + (forward-char) + ;; Property name (if present) + (if (eq (following-char) ?\( ) + (let ((p (point))) + (forward-sexp) + (delete-region p (point)))) + ;; Markup sequence. + (if (eq (following-char) ?:) + ;; :value: + (let ((p (point))) + (forward-char) + (forward-sexp) + (unless (eobp) + (forward-char)) + (delete-region p (point))) + ;; X: + (delete-char 1) ; The one-letter form. + (delete-char 1))))))) ; The colon. + + +(defun faceup-clean-string (s) + "Remove faceup markup from string S." + (with-temp-buffer + (insert s) + (faceup-clean-buffer) + (buffer-substring (point-min) (point-max)))) + + +;; ---------------------------------------------------------------------- +;; Regression test support +;; + +(defvar faceup-test-explain nil + "When non-nil, tester functions returns a text description on failure. + +Of course, this only work for test functions aware of this +variable, like `faceup-test-equal' and functions based on this +function. + +This is intended to be used to simplify `ert' explain functions, +which could be defined as: + + (defun my-test (args...) ...) + (defun my-test-explain (args...) + (let ((faceup-test-explain t)) + (the-test args...))) + (put 'my-test 'ert-explainer 'my-test-explain) + +Alternative, you can use the macro `faceup-defexplainer' as follows: + + (defun my-test (args...) ...) + (faceup-defexplainer my-test) + +Test functions, like `faceup-test-font-lock-buffer', built on top +of `faceup-test-equal', and other functions that adhere to this +variable, can easily define their own explainer functions.") + +;;;###autoload +(defmacro faceup-defexplainer (function) + "Define an Ert explainer function for FUNCTION. + +FUNCTION must return an explanation when the test fails and +`faceup-test-explain' is set." + (let ((name (intern (concat (symbol-name function) "-explainer")))) + `(progn + (defun ,name (&rest args) + (let ((faceup-test-explain t)) + (apply (quote ,function) args))) + (put (quote ,function) 'ert-explainer (quote ,name))))) + + +;; ------------------------------ +;; Multi-line string support. +;; + +(defun faceup-test-equal (lhs rhs) + "Compares two (multi-line) strings, LHS and RHS, for equality. + +This is intended to be used in Ert regression test rules. + +When `faceup-test-explain' is non-nil, instead of returning nil +on inequality, a list is returned with a explanation what +differs. Currently, this function reports 1) if the number of +lines in the strings differ. 2) the lines and the line numbers on +which the string differed. + +For example: + (let ((a \"ABC\\nDEF\\nGHI\") + (b \"ABC\\nXXX\\nGHI\\nZZZ\") + (faceup-test-explain t)) + (message \"%s\" (faceup-test-equal a b))) + + ==> (4 3 number-of-lines-differ (on-line 2 (DEF) (XXX))) + +When used in an `ert' rule, the output is as below: + + (ert-deftest faceup-test-equal-example () + (let ((a \"ABC\\nDEF\\nGHI\") + (b \"ABC\\nXXX\\nGHI\\nZZZ\")) + (should (faceup-test-equal a b)))) + + F faceup-test-equal-example + (ert-test-failed + ((should + (faceup-test-equal a b)) + :form + (faceup-test-equal \"ABC\\nDEF\\nGHI\" \"ABC\\nXXX\\nGHI\\nZZZ\") + :value nil :explanation + (4 3 number-of-lines-differ + (on-line 2 + (\"DEF\") + (\"XXX\")))))" + (if (equal lhs rhs) + t + (if faceup-test-explain + (let ((lhs-lines (split-string lhs "\n")) + (rhs-lines (split-string rhs "\n")) + (explanation '()) + (line 1)) + (unless (= (length lhs-lines) (length rhs-lines)) + (setq explanation (list 'number-of-lines-differ + (length lhs-lines) (length rhs-lines)))) + (while lhs-lines + (let ((one (pop lhs-lines)) + (two (pop rhs-lines))) + (unless (equal one two) + (setq explanation + (cons (list 'on-line line (list one) (list two)) + explanation))) + (setq line (+ line 1)))) + (nreverse explanation)) + nil))) + +(faceup-defexplainer faceup-test-equal) + + +;; ------------------------------ +;; Font-lock regression test support. +;; + +(defun faceup-test-font-lock-buffer (mode faceup &optional buffer) + "Verify that BUFFER is fontified as FACEUP for major mode MODE. + +If BUFFER is not specified the current buffer is used. + +Note that the major mode of the buffer is set to MODE and that +the buffer is fontified. + +If MODE is a list, the first element is the major mode, the +remaining are additional functions to call, e.g. minor modes." + (save-excursion + (if buffer + (set-buffer buffer)) + (if (listp mode) + (dolist (m mode) + (funcall m)) + (funcall mode)) + (font-lock-fontify-region (point-min) (point-max)) + (let ((result (faceup-markup-buffer))) + (faceup-test-equal faceup result)))) + +(faceup-defexplainer faceup-test-font-lock-buffer) + + +(defun faceup-test-font-lock-string (mode faceup) + "True if FACEUP is re-fontified as the faceup markup for major mode MODE. + +The string FACEUP is stripped from markup, inserted into a +buffer, the requested major mode activated, the buffer is +fontified, the result is again converted to the faceup form, and +compared with the original string." + (with-temp-buffer + (insert faceup) + (faceup-clean-buffer) + (faceup-test-font-lock-buffer mode faceup))) + +(faceup-defexplainer faceup-test-font-lock-string) + + +(defun faceup-test-font-lock-file (mode file &optional faceup-file) + "Verify that FILE is fontified as FACEUP-FILE for major mode MODE. + +If FACEUP-FILE is omitted, FILE.faceup is used." + (unless faceup-file + (setq faceup-file (concat file ".faceup"))) + (let ((faceup (with-temp-buffer + (insert-file-contents faceup-file) + (buffer-substring-no-properties (point-min) (point-max))))) + (with-temp-buffer + (insert-file-contents file) + (faceup-test-font-lock-buffer mode faceup)))) + +(faceup-defexplainer faceup-test-font-lock-file) + + +;; ------------------------------ +;; Get current file directory. Test cases can use this to locate test +;; files. +;; + +(defun faceup-this-file-directory () + "The directory of the file where the call to this function is located in. +Intended to be called when a file is loaded." + (expand-file-name + (if load-file-name + ;; File is being loaded. + (file-name-directory load-file-name) + ;; File is being evaluated using, for example, `eval-buffer'. + default-directory))) + + +;; ---------------------------------------------------------------------- +;; The end +;; + +(provide 'faceup) + +;;; faceup.el ends here diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index ed8dc74506f..300bfab3233 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -368,28 +368,30 @@ The search is done in the source for library LIBRARY." (concat "\\\\?" (regexp-quote (symbol-name symbol)))))) (case-fold-search)) - (with-syntax-table emacs-lisp-mode-syntax-table - (goto-char (point-min)) - (if (if (functionp regexp) - (funcall regexp symbol) - (or (re-search-forward regexp nil t) - ;; `regexp' matches definitions using known forms like - ;; `defun', or `defvar'. But some functions/variables - ;; are defined using special macros (or functions), so - ;; if `regexp' can't find the definition, we look for - ;; something of the form "(SOMETHING <symbol> ...)". - ;; This fails to distinguish function definitions from - ;; variable declarations (or even uses thereof), but is - ;; a good pragmatic fallback. - (re-search-forward - (concat "^([^ ]+" find-function-space-re "['(]?" - (regexp-quote (symbol-name symbol)) - "\\_>") - nil t))) - (progn - (beginning-of-line) - (cons (current-buffer) (point))) - (cons (current-buffer) nil)))))))) + (save-restriction + (widen) + (with-syntax-table emacs-lisp-mode-syntax-table + (goto-char (point-min)) + (if (if (functionp regexp) + (funcall regexp symbol) + (or (re-search-forward regexp nil t) + ;; `regexp' matches definitions using known forms like + ;; `defun', or `defvar'. But some functions/variables + ;; are defined using special macros (or functions), so + ;; if `regexp' can't find the definition, we look for + ;; something of the form "(SOMETHING <symbol> ...)". + ;; This fails to distinguish function definitions from + ;; variable declarations (or even uses thereof), but is + ;; a good pragmatic fallback. + (re-search-forward + (concat "^([^ ]+" find-function-space-re "['(]?" + (regexp-quote (symbol-name symbol)) + "\\_>") + nil t))) + (progn + (beginning-of-line) + (cons (current-buffer) (point))) + (cons (current-buffer) nil))))))))) (defun find-function-library (function &optional lisp-only verbose) "Return the pair (ORIG-FUNCTION . LIBRARY) for FUNCTION. diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index e210def1a0f..d3e883996e2 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -303,7 +303,9 @@ The return value is the last VAL in the list. (lambda (do before index place) (gv-letplace (getter setter) place (funcall do `(edebug-after ,before ,index ,getter) - setter)))) + (lambda (store) + `(progn (edebug-after ,before ,index ,getter) + ,(funcall setter store))))))) ;;; The common generalized variables. diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 94be5acd6d3..4e5b1a7e4ff 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -461,11 +461,6 @@ This will generate compile-time constants from BINDINGS." (throw 'found t))))))) (1 'font-lock-regexp-grouping-backslash prepend) (3 'font-lock-regexp-grouping-construct prepend)) - ;; This is too general -- rms. - ;; A user complained that he has functions whose names start with `do' - ;; and that they get the wrong color. - ;; ;; CL `with-' and `do-' constructs - ;;("(\\(\\(do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face) (lisp--match-hidden-arg (0 '(face font-lock-warning-face help-echo "Hidden behind deeper element; move to another line?"))) @@ -491,6 +486,11 @@ This will generate compile-time constants from BINDINGS." (,(concat "[`‘]\\(\\(?:\\sw\\|\\s_\\|\\\\.\\)" lisp-mode-symbol-regexp "\\)['’]") (1 font-lock-constant-face prepend)) + ;; Uninterned symbols, e.g., (defpackage #:my-package ...) + ;; must come before keywords below to have effect + (,(concat "\\(#:\\)\\(" lisp-mode-symbol-regexp "\\)") + (1 font-lock-comment-delimiter-face) + (2 font-lock-doc-face)) ;; Constant values. (,(concat "\\_<:" lisp-mode-symbol-regexp "\\_>") (0 font-lock-builtin-face)) @@ -500,8 +500,10 @@ This will generate compile-time constants from BINDINGS." ;; This is too general -- rms. ;; A user complained that he has functions whose names start with `do' ;; and that they get the wrong color. - ;; ;; CL `with-' and `do-' constructs - ;;("(\\(\\(do-\\|with-\\)\\(\\s_\\|\\w\\)*\\)" 1 font-lock-keyword-face) + ;; That user has violated the http://www.cliki.net/Naming+conventions: + ;; CL (but not EL!) `with-' (context) and `do-' (iteration) + (,(concat "(\\(\\(do-\\|with-\\)" lisp-mode-symbol-regexp "\\)") + (1 font-lock-keyword-face)) (lisp--match-hidden-arg (0 '(face font-lock-warning-face help-echo "Hidden behind deeper element; move to another line?"))) diff --git a/lisp/emacs-lisp/lisp.el b/lisp/emacs-lisp/lisp.el index 1777779b75c..5aa3ac8742a 100644 --- a/lisp/emacs-lisp/lisp.el +++ b/lisp/emacs-lisp/lisp.el @@ -339,12 +339,18 @@ is called as a function to find the defun's beginning." ((or defun-prompt-regexp open-paren-in-column-0-is-defun-start) (and (< arg 0) (not (eobp)) (forward-char 1)) - (and (re-search-backward (if defun-prompt-regexp - (concat (if open-paren-in-column-0-is-defun-start - "^\\s(\\|" "") - "\\(?:" defun-prompt-regexp "\\)\\s(") - "^\\s(") - nil 'move arg) + (and (let (found) + (while + (and (setq found + (re-search-backward + (if defun-prompt-regexp + (concat (if open-paren-in-column-0-is-defun-start + "^\\s(\\|" "") + "\\(?:" defun-prompt-regexp "\\)\\s(") + "^\\s(") + nil 'move arg)) + (nth 8 (syntax-ppss)))) + found) (progn (goto-char (1- (match-end 0))) t))) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 853e9cb2acd..71d1c41ec3c 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -101,7 +101,7 @@ ;; Michael Olson <mwolson@member.fsf.org> ;; Sebastian Tennant <sebyte@smolny.plus.com> ;; Stefan Monnier <monnier@iro.umontreal.ca> -;; Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Phil Hagelberg <phil@hagelb.org> ;;; ToDo: @@ -961,17 +961,12 @@ This assumes that `pkg-desc' has already been activated with (defun package-read-from-string (str) "Read a Lisp expression from STR. Signal an error if the entire string was not used." - (let* ((read-data (read-from-string str)) - (more-left - (condition-case nil - ;; The call to `ignore' suppresses a compiler warning. - (progn (ignore (read-from-string - (substring str (cdr read-data)))) - t) - (end-of-file nil)))) - (if more-left - (error "Can't read whole string") - (car read-data)))) + (pcase-let ((`(,expr . ,offset) (read-from-string str))) + (condition-case () + ;; The call to `ignore' suppresses a compiler warning. + (progn (ignore (read-from-string str offset)) + (error "Can't read whole string")) + (end-of-file expr)))) (defun package--prepare-dependencies (deps) "Turn DEPS into an acceptable list of dependencies. diff --git a/lisp/emacs-lisp/testcover.el b/lisp/emacs-lisp/testcover.el index dff990ea401..613f69c4f62 100644 --- a/lisp/emacs-lisp/testcover.el +++ b/lisp/emacs-lisp/testcover.el @@ -33,7 +33,9 @@ ;; that has a splotch. ;; * Basic algorithm: use `edebug' to mark up the function text with -;; instrumentation callbacks, then replace edebug's callbacks with ours. +;; instrumentation callbacks, walk the instrumented code looking for +;; forms which don't return or always return the same value, then use +;; Edebug's before and after hooks to replace its code coverage with ours. ;; * To show good coverage, we want to see two values for every form, except ;; functions that always return the same value and `defconst' variables ;; need show only one value for good coverage. To avoid the brown @@ -47,11 +49,10 @@ ;; function being called is capable of returning in other cases. ;; Problems: -;; * To detect different values, we store the form's result in a vector and -;; compare the next result using `equal'. We don't copy the form's -;; result, so if caller alters it (`setcar', etc.) we'll think the next -;; call has the same value! Also, equal thinks two strings are the same -;; if they differ only in properties. +;; * `equal', which is used to compare the results of repeatedly executing +;; a form, has a couple of shortcomings. It considers strings to be the same +;; if they only differ in properties, and it raises an error when asked to +;; compare circular lists. ;; * Because we have only a "1value" class and no "always nil" class, we have ;; to treat as potentially 1-valued any `and' whose last term is 1-valued, ;; in case the last term is always nil. Example: @@ -89,16 +90,14 @@ these. This list is quite incomplete!" buffer-disable-undo buffer-enable-undo current-global-map deactivate-mark delete-backward-char delete-char delete-region ding forward-char function* insert insert-and-inherit kill-all-local-variables - kill-line kill-paragraph kill-region kill-sexp lambda + kill-line kill-paragraph kill-region kill-sexp minibuffer-complete-and-exit narrow-to-region next-line push-mark put-text-property run-hooks set-match-data signal substitute-key-definition suppress-keymap undo use-local-map while widen yank) - "Functions that always return the same value. No brown splotch is shown -for these. This list is quite incomplete! Notes: Nobody ever changes the -current global map. The macro `lambda' is self-evaluating, hence always -returns the same value (the function it defines may return varying values -when called)." + "Functions that always return the same value, according to `equal'. +No brown splotch is shown for these. This list is quite +incomplete! Notes: Nobody ever changes the current global map." :group 'testcover :type '(repeat symbol)) @@ -111,7 +110,7 @@ them as having returned nil just before calling them." (defcustom testcover-compose-functions '(+ - * / = append length list make-keymap make-sparse-keymap - mapcar message propertize replace-regexp-in-string + message propertize replace-regexp-in-string run-with-idle-timer set-buffer-modified-p) "Functions that are 1-valued if all their args are either constants or calls to one of the `testcover-1value-functions', so if that's true then no @@ -186,19 +185,18 @@ call to one of the `testcover-1value-functions'." ;;;###autoload (defun testcover-start (filename &optional byte-compile) - "Uses edebug to instrument all macros and functions in FILENAME, then -changes the instrumentation from edebug to testcover--much faster, no -problems with type-ahead or post-command-hook, etc. If BYTE-COMPILE is -non-nil, byte-compiles each function after instrumenting." + "Use Edebug to instrument for coverage all macros and functions in FILENAME. +If BYTE-COMPILE is non-nil, byte compile each function after instrumenting." (interactive "fStart covering file: ") - (let ((buf (find-file filename)) - (load-read-function load-read-function)) - (add-function :around load-read-function - #'testcover--read) - (setq edebug-form-data nil - testcover-module-constants nil - testcover-module-1value-functions nil) - (eval-buffer buf)) + (let ((buf (find-file filename))) + (setq edebug-form-data nil + testcover-module-constants nil + testcover-module-1value-functions nil + testcover-module-potentially-1value-functions nil) + (let ((edebug-all-defs t) + (edebug-after-instrumentation-function #'testcover-after-instrumentation) + (edebug-new-definition-function #'testcover-init-definition)) + (eval-buffer buf))) (when byte-compile (dolist (x (reverse edebug-form-data)) (when (fboundp (car x)) @@ -209,229 +207,10 @@ non-nil, byte-compiles each function after instrumenting." (defun testcover-this-defun () "Start coverage on function under point." (interactive) - (let ((x (let ((edebug-all-defs t)) - (symbol-function (eval-defun nil))))) - (testcover-reinstrument x) - x)) - -(defun testcover--read (orig &optional stream) - "Read a form using edebug, changing edebug callbacks to testcover callbacks." - (or stream (setq stream standard-input)) - (if (eq stream (current-buffer)) - (let ((x (let ((edebug-all-defs t)) - (edebug-read-and-maybe-wrap-form)))) - (testcover-reinstrument x) - x) - (funcall (or orig #'read) stream))) - -(defun testcover-reinstrument (form) - "Reinstruments FORM to use testcover instead of edebug. This -function modifies the list that FORM points to. Result is nil if -FORM should return multiple values, t if should always return same -value, `maybe' if either is acceptable." - (let ((fun (car-safe form)) - id val) - (cond - ((not fun) ;Atom - (when (or (not (symbolp form)) - (memq form testcover-constants) - (memq form testcover-module-constants)) - t)) - ((consp fun) ;Embedded list - (testcover-reinstrument fun) - (testcover-reinstrument-list (cdr form)) - nil) - ((or (memq fun testcover-1value-functions) - (memq fun testcover-module-1value-functions)) - ;;Should always return same value - (testcover-reinstrument-list (cdr form)) - t) - ((or (memq fun testcover-potentially-1value-functions) - (memq fun testcover-module-potentially-1value-functions)) - ;;Might always return same value - (testcover-reinstrument-list (cdr form)) - 'maybe) - ((memq fun testcover-progn-functions) - ;;1-valued if last argument is - (testcover-reinstrument-list (cdr form))) - ((memq fun testcover-prog1-functions) - ;;1-valued if first argument is - (testcover-reinstrument-list (cddr form)) - (testcover-reinstrument (cadr form))) - ((memq fun testcover-compose-functions) - ;;1-valued if all arguments are. Potentially 1-valued if all - ;;arguments are either definitely or potentially. - (testcover-reinstrument-compose (cdr form) 'testcover-reinstrument)) - ((eq fun 'edebug-enter) - ;;(edebug-enter 'SYM ARGS #'(lambda nil FORMS)) - ;; => (testcover-enter 'SYM #'(lambda nil FORMS)) - (setcar form 'testcover-enter) - (setcdr (nthcdr 1 form) (nthcdr 3 form)) - (let ((testcover-vector (get (cadr (cadr form)) 'edebug-coverage))) - (testcover-reinstrument-list (nthcdr 2 (cadr (nth 2 form)))))) - ((eq fun 'edebug-after) - ;;(edebug-after (edebug-before XXX) YYY FORM) - ;; => (testcover-after YYY FORM), mark XXX as ok-coverage - (unless (eq (cadr form) 0) - (aset testcover-vector (cadr (cadr form)) 'ok-coverage)) - (setq id (nth 2 form)) - (setcdr form (nthcdr 2 form)) - (setq val (testcover-reinstrument (nth 2 form))) - (setcar form (if (eq val t) - 'testcover-1value - 'testcover-after)) - (when val - ;;1-valued or potentially 1-valued - (aset testcover-vector id '1value)) - (cond - ((memq (car-safe (nth 2 form)) testcover-noreturn-functions) - ;;This function won't return, so set the value in advance - ;;(edebug-after (edebug-before XXX) YYY FORM) - ;; => (progn (edebug-after YYY nil) FORM) - (setcar (cdr form) `(,(car form) ,id nil)) - (setcar form 'progn) - (aset testcover-vector id '1value) - (setq val t)) - ((eq (car-safe (nth 2 form)) '1value) - ;;This function is always supposed to return the same value - (setq val t) - (aset testcover-vector id '1value) - (setcar form 'testcover-1value))) - val) - ((eq fun 'defun) - (setq val (testcover-reinstrument-list (nthcdr 3 form))) - (when (eq val t) - (push (cadr form) testcover-module-1value-functions)) - (when (eq val 'maybe) - (push (cadr form) testcover-module-potentially-1value-functions))) - ((memq fun '(defconst defcustom)) - ;;Define this symbol as 1-valued - (push (cadr form) testcover-module-constants) - (testcover-reinstrument-list (cddr form))) - ((memq fun '(dotimes dolist)) - ;;Always returns third value from SPEC - (testcover-reinstrument-list (cddr form)) - (setq val (testcover-reinstrument-list (cadr form))) - (if (nth 2 (cadr form)) - val - ;;No third value, always returns nil - t)) - ((memq fun '(let let*)) - ;;Special parsing for second argument - (mapc 'testcover-reinstrument-list (cadr form)) - (testcover-reinstrument-list (cddr form))) - ((eq fun 'if) - ;;Potentially 1-valued if both THEN and ELSE clauses are - (testcover-reinstrument (cadr form)) - (let ((then (testcover-reinstrument (nth 2 form))) - (else (testcover-reinstrument-list (nthcdr 3 form)))) - (and then else 'maybe))) - ((eq fun 'cond) - ;;Potentially 1-valued if all clauses are - (when (testcover-reinstrument-compose (cdr form) - 'testcover-reinstrument-list) - 'maybe)) - ((eq fun 'condition-case) - ;;Potentially 1-valued if BODYFORM is and all HANDLERS are - (let ((body (testcover-reinstrument (nth 2 form))) - (errs (testcover-reinstrument-compose - (mapcar #'cdr (nthcdr 3 form)) - 'testcover-reinstrument-list))) - (and body errs 'maybe))) - ((eq fun 'quote) - ;;Don't reinstrument what's inside! - ;;This doesn't apply within a backquote - t) - ((eq fun '\`) - ;;Quotes are not special within backquotes - (let ((testcover-1value-functions - (cons 'quote testcover-1value-functions))) - (testcover-reinstrument (cadr form)))) - ((eq fun '\,) - ;;In commas inside backquotes, quotes are special again - (let ((testcover-1value-functions - (remq 'quote testcover-1value-functions))) - (testcover-reinstrument (cadr form)))) - ((eq fun '1value) - ;;Hack - pretend the arg is 1-valued here - (cond - ((symbolp (cadr form)) - ;;A pseudoconstant variable - t) - ((and (eq (car (cadr form)) 'edebug-after) - (symbolp (nth 3 (cadr form)))) - ;;Reference to pseudoconstant - (aset testcover-vector (nth 2 (cadr form)) '1value) - (setcar (cdr form) `(testcover-1value ,(nth 2 (cadr form)) - ,(nth 3 (cadr form)))) - t) - (t - (setq id (car (if (eq (car (cadr form)) 'edebug-after) - (nth 3 (cadr form)) - (cadr form)))) - (let ((testcover-1value-functions - (cons id testcover-1value-functions))) - (testcover-reinstrument (cadr form)))))) - ((eq fun 'noreturn) - ;;Hack - pretend the arg has no return - (cond - ((symbolp (cadr form)) - ;;A pseudoconstant variable - 'maybe) - ((and (eq (car (cadr form)) 'edebug-after) - (symbolp (nth 3 (cadr form)))) - ;;Reference to pseudoconstant - (aset testcover-vector (nth 2 (cadr form)) '1value) - (setcar (cdr form) `(progn (testcover-after ,(nth 2 (cadr form)) nil) - ,(nth 3 (cadr form)))) - 'maybe) - (t - (setq id (car (if (eq (car (cadr form)) 'edebug-after) - (nth 3 (cadr form)) - (cadr form)))) - (let ((testcover-noreturn-functions - (cons id testcover-noreturn-functions))) - (testcover-reinstrument (cadr form)))))) - ((and (eq fun 'apply) - (eq (car-safe (cadr form)) 'quote) - (symbolp (cadr (cadr form)))) - ;;Apply of a constant symbol. Process as 1value or noreturn - ;;depending on symbol. - (setq fun (cons (cadr (cadr form)) (cddr form)) - val (testcover-reinstrument fun)) - (setcdr (cdr form) (cdr fun)) - val) - (t ;Some other function or weird thing - (testcover-reinstrument-list (cdr form)) - nil)))) - -(defun testcover-reinstrument-list (list) - "Reinstruments each form in LIST to use testcover instead of edebug. -This function modifies the forms in LIST. Result is `testcover-reinstrument's -value for the last form in LIST. If the LIST is empty, its evaluation will -always be nil, so we return t for 1-valued." - (let ((result t)) - (while (consp list) - (setq result (testcover-reinstrument (pop list)))) - result)) - -(defun testcover-reinstrument-compose (list fun) - "For a compositional function, the result is 1-valued if all -arguments are, potentially 1-valued if all arguments are either -definitely or potentially 1-valued, and multi-valued otherwise. -FUN should be `testcover-reinstrument' for compositional functions, - `testcover-reinstrument-list' for clauses in a `cond'." - (let ((result t)) - (mapc #'(lambda (x) - (setq x (funcall fun x)) - (cond - ((eq result t) - (setq result x)) - ((eq result 'maybe) - (when (not x) - (setq result nil))))) - list) - result)) + (let ((edebug-all-defs t) + (edebug-after-instrumentation-function #'testcover-after-instrumentation) + (edebug-new-definition-function #'testcover-init-definition)) + (eval-defun nil))) (defun testcover-end (filename) "Turn off instrumentation of all macros and functions in FILENAME." @@ -444,48 +223,108 @@ FUN should be `testcover-reinstrument' for compositional functions, ;;; Accumulate coverage data ;;;========================================================================= -(defun testcover-enter (testcover-sym testcover-fun) - "Internal function for coverage testing. Invokes TESTCOVER-FUN while -binding `testcover-vector' to the code-coverage vector for TESTCOVER-SYM -\(the name of the current function)." - (let ((testcover-vector (get testcover-sym 'edebug-coverage))) - (funcall testcover-fun))) - -(defun testcover-after (idx val) - "Internal function for coverage testing. Returns VAL after installing it in -`testcover-vector' at offset IDX." - (declare (gv-expander (lambda (do) - (gv-letplace (getter setter) val - (funcall do getter - (lambda (store) - `(progn (testcover-after ,idx ,getter) - ,(funcall setter store)))))))) - (cond - ((eq (aref testcover-vector idx) 'unknown) - (aset testcover-vector idx val)) - ((not (condition-case () - (equal (aref testcover-vector idx) val) - ;; TODO: Actually check circular lists for equality. - (circular-list nil))) - (aset testcover-vector idx 'ok-coverage))) - val) - -(defun testcover-1value (idx val) - "Internal function for coverage testing. Returns VAL after installing it in -`testcover-vector' at offset IDX. Error if FORM does not always return the -same value during coverage testing." - (cond - ((eq (aref testcover-vector idx) '1value) - (aset testcover-vector idx (cons '1value val))) - ((not (and (eq (car-safe (aref testcover-vector idx)) '1value) - (condition-case () - (equal (cdr (aref testcover-vector idx)) val) - ;; TODO: Actually check circular lists for equality. - (circular-list nil)))) - (error "Value of form marked with `1value' does vary: %s" val))) - val) - - +(defun testcover-after-instrumentation (form) + "Analyze FORM for code coverage." + (testcover-analyze-coverage form) + form) + +(defun testcover-init-definition (sym) + "Mark SYM as under test coverage." + (message "Testcover: %s" sym) + (put sym 'edebug-behavior 'testcover)) + +(defun testcover-enter (func _args body) + "Begin execution of a function under coverage testing. +Bind `testcover-vector' to the code-coverage vector for FUNC and +return the result of evaluating BODY." + (let ((testcover-vector (get func 'edebug-coverage))) + (funcall body))) + +(defun testcover-before (before-index) + "Update code coverage before a form is evaluated. +BEFORE-INDEX is the form's index into the code-coverage vector." + (let ((before-entry (aref testcover-vector before-index))) + (when (eq (car-safe before-entry) 'noreturn) + (let* ((after-index (cdr before-entry))) + (aset testcover-vector after-index 'ok-coverage))))) + +(defun testcover-after (_before-index after-index value) + "Update code coverage with the result of a form's evaluation. +AFTER-INDEX is the form's index into the code-coverage +vector. Return VALUE." + (let ((old-result (aref testcover-vector after-index))) + (cond + ((eq 'unknown old-result) + (aset testcover-vector after-index (testcover--copy-object value))) + ((eq 'maybe old-result) + (aset testcover-vector after-index 'ok-coverage)) + ((eq '1value old-result) + (aset testcover-vector after-index + (cons old-result (testcover--copy-object value)))) + ((and (eq (car-safe old-result) '1value) + (not (condition-case () + (equal (cdr old-result) value) + (circular-list t)))) + (error "Value of form expected to be constant does vary, from %s to %s" + old-result value)) + ;; Test if a different result. + ((not (condition-case () + (equal value old-result) + (circular-list nil))) + (aset testcover-vector after-index 'ok-coverage)))) + value) + +;; Add these behaviors to Edebug. +(unless (assoc 'testcover edebug-behavior-alist) + (push '(testcover testcover-enter testcover-before testcover-after) + edebug-behavior-alist)) + +(defun testcover--copy-object (obj) + "Make a copy of OBJ. +If OBJ is a cons cell, copy both its car and its cdr. +Contrast to `copy-tree' which does the same but fails on circular +structures, and `copy-sequence', which copies only along the +cdrs. Copy vectors as well as conses." + (let ((ht (make-hash-table :test 'eq))) + (testcover--copy-object1 obj t ht))) + +(defun testcover--copy-object1 (obj vecp hash-table) + "Make a copy of OBJ, using a HASH-TABLE of objects already copied. +If OBJ is a cons cell, this recursively copies its car and +iteratively copies its cdr. When VECP is non-nil, copy +vectors as well as conses." + (if (and (atom obj) (or (not vecp) (not (vectorp obj)))) + obj + (let ((copy (gethash obj hash-table nil))) + (unless copy + (cond + ((consp obj) + (let* ((rest obj) current) + (setq copy (cons nil nil) + current copy) + (while + (progn + (puthash rest current hash-table) + (setf (car current) + (testcover--copy-object1 (car rest) vecp hash-table)) + (setq rest (cdr rest)) + (cond + ((atom rest) + (setf (cdr current) + (testcover--copy-object1 rest vecp hash-table)) + nil) + ((gethash rest hash-table nil) + (setf (cdr current) (gethash rest hash-table nil)) + nil) + (t (setq current + (setf (cdr current) (cons nil nil))))))))) + (t ; (and vecp (vectorp obj)) is true due to test in if above. + (setq copy (copy-sequence obj)) + (puthash obj copy hash-table) + (dotimes (i (length copy)) + (aset copy i + (testcover--copy-object1 (aref copy i) vecp hash-table)))))) + copy))) ;;;========================================================================= ;;; Display the coverage data as color splotches on your code. @@ -517,12 +356,13 @@ eliminated by adding more test cases." (while (> len 0) (setq len (1- len) data (aref coverage len)) - (when (and (not (eq data 'ok-coverage)) - (not (eq (car-safe data) '1value)) - (setq j (+ def-mark (aref points len)))) + (when (and (not (eq data 'ok-coverage)) + (not (memq (car-safe data) + '(1value maybe noreturn))) + (setq j (+ def-mark (aref points len)))) (setq ov (make-overlay (1- j) j)) (overlay-put ov 'face - (if (memq data '(unknown 1value)) + (if (memq data '(unknown maybe 1value)) 'testcover-nohits 'testcover-1value)))) (set-buffer-modified-p changed)))) @@ -553,4 +393,284 @@ coverage tests. This function creates many overlays." (goto-char (next-overlay-change (point))) (end-of-line)) + +;;; Coverage Analysis + +;; The top level function for initializing code coverage is +;; `testcover-analyze-coverage', which recursively walks the form it is +;; passed, which should have already been instrumented by +;; edebug-read-and-maybe-wrap-form, and initializes the associated +;; code coverage vectors, which should have already been created by +;; `edebug-clear-coverage'. +;; +;; The purpose of the analysis is to identify forms which can only +;; ever return a single value. These forms can be considered to have +;; adequate code coverage even if only executed once. In addition, +;; forms which will never return, such as error signals, can be +;; identified and treated correctly. +;; +;; The code coverage vector entries for the beginnings of forms will +;; be changed to `ok-coverage.', except for the beginnings of forms +;; which should never return, which will be changed to +;; (noreturn . AFTER-INDEX) so that testcover-before can set the entry +;; for the end of the form just before it is executed. +;; +;; Entries for the ends of forms may be changed to `1value' if +;; analysis determines the form will only ever return a single value, +;; or `maybe' if the form could potentially only ever return a single +;; value. +;; +;; An example of a potentially 1-valued form is an `and' whose last +;; term is 1-valued, in case the last term is always nil. Example: +;; +;; (and (< (point) 1000) (forward-char 10)) +;; +;; This form always returns nil. Similarly, `or', `if', and `cond' +;; are treated as potentially 1-valued if all clauses are, in case +;; those values are always nil. Unlike truly 1-valued functions, it +;; is not an error if these "potentially" 1-valued forms actually +;; return differing values. + +(defun testcover-analyze-coverage (form) + "Analyze FORM and initialize coverage vectors for definitions found within. +Return 1value, maybe or nil depending on if the form is determined +to return only a single value, potentially return only a single value, +or return multiple values." + (pcase form + (`(edebug-enter ',sym ,_ (function (lambda nil . ,body))) + (let ((testcover-vector (get sym 'edebug-coverage))) + (testcover-analyze-coverage-progn body))) + + (`(edebug-after ,(and before-form + (or `(edebug-before ,before-id) before-id)) + ,after-id ,wrapped-form) + (testcover-analyze-coverage-edebug-after + form before-form before-id after-id wrapped-form)) + + (`(defconst ,sym . ,args) + (push sym testcover-module-constants) + (testcover-analyze-coverage-progn args) + '1value) + + (`(defun ,name ,_ . ,doc-and-body) + (let ((val (testcover-analyze-coverage-progn doc-and-body))) + (cl-case val + ((1value) (push name testcover-module-1value-functions)) + ((maybe) (push name testcover-module-potentially-1value-functions))) + nil)) + + (`(quote . ,_) + ;; A quoted form is 1value. Edebug could have instrumented + ;; something inside the form if an Edebug spec contained a quote. + ;; It's also possible that the quoted form is a circular object. + ;; To avoid infinite recursion, don't examine quoted objects. + ;; This will cause the coverage marks on an instrumented quoted + ;; form to look odd. See bug#25316. + '1value) + + (`(\` ,bq-form) + (testcover-analyze-coverage-backquote-form bq-form)) + + ((or 't 'nil (pred keywordp)) + '1value) + + ((pred vectorp) + (testcover-analyze-coverage-compose (append form nil) + #'testcover-analyze-coverage)) + + ((pred symbolp) + nil) + + ((pred atom) + '1value) + + (_ + ;; Whatever we have here, it's not wrapped, so treat it as a list of forms. + (testcover-analyze-coverage-compose form #'testcover-analyze-coverage)))) + +(defun testcover-analyze-coverage-progn (forms) + "Analyze FORMS, which should be a list of forms, for code coverage. +Analyze all the forms in FORMS and return 1value, maybe or nil +depending on the analysis of the last one. Find the coverage +vectors referenced by `edebug-enter' forms nested within FORMS and +update them with the results of the analysis." + (let ((result '1value)) + (while (consp forms) + (setq result (testcover-analyze-coverage (pop forms)))) + result)) + +(defun testcover-analyze-coverage-edebug-after (_form before-form before-id + after-id wrapped-form + &optional wrapper) + "Analyze a _FORM wrapped by `edebug-after' for code coverage. +_FORM should be either: + (edebug-after (edebug-before BEFORE-ID) AFTER-ID WRAPPED-FORM) +or: + (edebug-after 0 AFTER-ID WRAPPED-FORM) + +where BEFORE-FORM is bound to either (edebug-before BEFORE-ID) or +0. WRAPPER may be 1value or noreturn, and if so it forces the +form to be treated accordingly." + (let (val) + (unless (eql before-form 0) + (aset testcover-vector before-id 'ok-coverage)) + + (setq val (testcover-analyze-coverage-wrapped-form wrapped-form)) + (when (or (eq wrapper '1value) val) + ;; The form is 1-valued or potentially 1-valued. + (aset testcover-vector after-id (or val '1value))) + + (cond + ((or (eq wrapper 'noreturn) + (memq (car-safe wrapped-form) testcover-noreturn-functions)) + ;; This function won't return, so indicate to testcover-before that + ;; it should record coverage. + (aset testcover-vector before-id (cons 'noreturn after-id)) + (aset testcover-vector after-id '1value) + (setq val '1value)) + + ((eq (car-safe wrapped-form) '1value) + ;; This function is always supposed to return the same value. + (setq val '1value) + (aset testcover-vector after-id '1value))) + val)) + +(defun testcover-analyze-coverage-wrapped-form (form) + "Analyze a FORM for code coverage which was wrapped by `edebug-after'. +FORM is treated as if it will be evaluated." + (pcase form + ((pred keywordp) + '1value) + ((pred symbolp) + (when (or (memq form testcover-constants) + (memq form testcover-module-constants)) + '1value)) + ((pred atom) + '1value) + (`(\` ,bq-form) + (testcover-analyze-coverage-backquote-form bq-form)) + (`(defconst ,sym ,val . ,_) + (push sym testcover-module-constants) + (testcover-analyze-coverage val) + '1value) + (`(,(or 'dotimes 'dolist) (,_ ,expr . ,result) . ,body) + ;; These always return RESULT if provided. + (testcover-analyze-coverage expr) + (testcover-analyze-coverage-progn body) + (let ((val (testcover-analyze-coverage-progn result))) + ;; If the third value is not present, the loop always returns nil. + (if result val '1value))) + (`(,(or 'let 'let*) ,bindings . ,body) + (testcover-analyze-coverage-progn bindings) + (testcover-analyze-coverage-progn body)) + (`(if ,test ,then-form . ,else-body) + ;; `if' is potentially 1-valued if both THEN and ELSE clauses are. + (testcover-analyze-coverage test) + (let ((then (testcover-analyze-coverage then-form)) + (else (testcover-analyze-coverage else-body))) + (and then else 'maybe))) + (`(cond . ,clauses) + ;; `cond' is potentially 1-valued if all clauses are. + (when (testcover-analyze-coverage-compose clauses #'testcover-analyze-coverage-progn) + 'maybe)) + (`(condition-case ,_ ,body-form . ,handlers) + ;; `condition-case' is potentially 1-valued if BODY-FORM is and all + ;; HANDLERS are. + (let ((body (testcover-analyze-coverage body-form)) + (errs (testcover-analyze-coverage-compose + (mapcar #'cdr handlers) + #'testcover-analyze-coverage-progn))) + (and body errs 'maybe))) + (`(apply (quote ,(and func (pred symbolp))) . ,args) + ;; Process application of a constant symbol as 1value or noreturn + ;; depending on the symbol. + (let ((temp-form (cons func args))) + (testcover-analyze-coverage-wrapped-form temp-form))) + (`(,(and func (or '1value 'noreturn)) ,inner-form) + ;; 1value and noreturn change how the edebug-after they wrap is handled. + (let ((val (if (eq func '1value) '1value 'maybe))) + (pcase inner-form + (`(edebug-after ,(and before-form + (or `(edebug-before ,before-id) before-id)) + ,after-id ,wrapped-form) + (testcover-analyze-coverage-edebug-after inner-form before-form + before-id after-id + wrapped-form func)) + (_ (testcover-analyze-coverage inner-form))) + val)) + (`(,func . ,args) + (testcover-analyze-coverage-wrapped-application func args)))) + +(defun testcover-analyze-coverage-wrapped-application (func args) + "Analyze the application of FUNC to ARGS for code coverage." + (cond + ((eq func 'quote) '1value) + ((or (memq func testcover-1value-functions) + (memq func testcover-module-1value-functions)) + ;; The function should always return the same value. + (testcover-analyze-coverage-progn args) + '1value) + ((or (memq func testcover-potentially-1value-functions) + (memq func testcover-module-potentially-1value-functions)) + ;; The function might always return the same value. + (testcover-analyze-coverage-progn args) + 'maybe) + ((memq func testcover-progn-functions) + ;; The function is 1-valued if the last argument is. + (testcover-analyze-coverage-progn args)) + ((memq func testcover-prog1-functions) + ;; The function is 1-valued if first argument is. + (testcover-analyze-coverage-progn (cdr args)) + (testcover-analyze-coverage (car args))) + ((memq func testcover-compose-functions) + ;; The function is 1-valued if all arguments are, and potentially + ;; 1-valued if all arguments are either definitely or potentially. + (testcover-analyze-coverage-compose args #'testcover-analyze-coverage)) + (t (testcover-analyze-coverage-progn args) + nil))) + +(defun testcover-coverage-combine (result val) + "Combine RESULT with VAL and return the new result. +If either argument is nil, return nil, otherwise if either +argument is maybe, return maybe. Return 1value only if both arguments +are 1value." + (cl-case val + (1value result) + (maybe (and result 'maybe)) + (nil nil))) + +(defun testcover-analyze-coverage-compose (forms func) + "Analyze a list of FORMS for code coverage using FUNC. +The list is 1valued if all of its constituent elements are also 1valued." + (let ((result '1value)) + (dolist (form forms) + (let ((val (funcall func form))) + (setq result (testcover-coverage-combine result val)))) + result)) + +(defun testcover-analyze-coverage-backquote (bq-list) + "Analyze BQ-LIST, the body of a backquoted list, for code coverage." + (let ((result '1value)) + (while (consp bq-list) + (let ((form (car bq-list)) + val) + (if (memq form (list '\, '\,@)) + ;; Correctly handle `(foo bar . ,(baz). + (progn + (setq val (testcover-analyze-coverage (cdr bq-list))) + (setq bq-list nil)) + (setq val (testcover-analyze-coverage-backquote-form form)) + (setq bq-list (cdr bq-list))) + (setq result (testcover-coverage-combine result val)))) + result)) + +(defun testcover-analyze-coverage-backquote-form (form) + "Analyze a single FORM from a backquoted list for code coverage." + (cond + ((vectorp form) (testcover-analyze-coverage-backquote (append form nil))) + ((atom form) '1value) + ((memq (car form) (list '\, '\,@)) + (testcover-analyze-coverage (cadr form))) + (t (testcover-analyze-coverage-backquote form)))) + ;; testcover.el ends here. diff --git a/lisp/emacs-lisp/thunk.el b/lisp/emacs-lisp/thunk.el index f12633e6de1..bbdd7d61f6c 100644 --- a/lisp/emacs-lisp/thunk.el +++ b/lisp/emacs-lisp/thunk.el @@ -29,9 +29,9 @@ ;; Thunk provides functions and macros to delay the evaluation of ;; forms. ;; -;; Use `thunk-delay' to delay the evaluation of a form, and -;; `thunk-force' to evaluate it. The result of the evaluation is -;; cached, and only happens once. +;; Use `thunk-delay' to delay the evaluation of a form (requires +;; lexical-binding), and `thunk-force' to evaluate it. The result of +;; the evaluation is cached, and only happens once. ;; ;; Here is an example of a form which evaluation is delayed: ;; @@ -41,12 +41,19 @@ ;; following: ;; ;; (thunk-force delayed) +;; +;; This file also defines macros `thunk-let' and `thunk-let*' that are +;; analogous to `let' and `let*' but provide lazy evaluation of +;; bindings by using thunks implicitly (i.e. in the expansion). ;;; Code: +(eval-when-compile (require 'cl-macs)) + (defmacro thunk-delay (&rest body) "Delay the evaluation of BODY." (declare (debug t)) + (cl-assert lexical-binding) (let ((forced (make-symbol "forced")) (val (make-symbol "val"))) `(let (,forced ,val) @@ -68,5 +75,60 @@ with the same DELAYED argument." "Return non-nil if DELAYED has been evaluated." (funcall delayed t)) +(defmacro thunk-let (bindings &rest body) + "Like `let' but create lazy bindings. + +BINDINGS is a list of elements of the form (SYMBOL EXPRESSION). +Any binding EXPRESSION is not evaluated before the variable +SYMBOL is used for the first time when evaluating the BODY. + +It is not allowed to set `thunk-let' or `thunk-let*' bound +variables. + +Using `thunk-let' and `thunk-let*' requires `lexical-binding'." + (declare (indent 1) (debug let)) + (cl-callf2 mapcar + (lambda (binding) + (pcase binding + (`(,(pred symbolp) ,_) binding) + (_ (signal 'error (cons "Bad binding in thunk-let" + (list binding)))))) + bindings) + (cl-callf2 mapcar + (pcase-lambda (`(,var ,binding)) + (list (make-symbol (concat (symbol-name var) "-thunk")) + var binding)) + bindings) + `(let ,(mapcar + (pcase-lambda (`(,thunk-var ,_var ,binding)) + `(,thunk-var (thunk-delay ,binding))) + bindings) + (cl-symbol-macrolet + ,(mapcar (pcase-lambda (`(,thunk-var ,var ,_binding)) + `(,var (thunk-force ,thunk-var))) + bindings) + ,@body))) + +(defmacro thunk-let* (bindings &rest body) + "Like `let*' but create lazy bindings. + +BINDINGS is a list of elements of the form (SYMBOL EXPRESSION). +Any binding EXPRESSION is not evaluated before the variable +SYMBOL is used for the first time when evaluating the BODY. + +It is not allowed to set `thunk-let' or `thunk-let*' bound +variables. + +Using `thunk-let' and `thunk-let*' requires `lexical-binding'." + (declare (indent 1) (debug let)) + (cl-reduce + (lambda (expr binding) `(thunk-let (,binding) ,expr)) + (nreverse bindings) + :initial-value (macroexp-progn body))) + +;; (defalias 'lazy-let #'thunk-let) +;; (defalias 'lazy-let* #'thunk-let*) + + (provide 'thunk) ;;; thunk.el ends here diff --git a/lisp/epa.el b/lisp/epa.el index d2ad80e8fee..2b14a003484 100644 --- a/lisp/epa.el +++ b/lisp/epa.el @@ -562,7 +562,7 @@ If SECRET is non-nil, list secret keys instead of public keys." (epg-sub-key-creation-time (car pointer))) (error "????-??-??")) (if (epg-sub-key-expiration-time (car pointer)) - (format (if (time-less-p (current-time) + (format (if (time-less-p nil (epg-sub-key-expiration-time (car pointer))) "\n\tExpires: %s" diff --git a/lisp/erc/erc-autoaway.el b/lisp/erc/erc-autoaway.el index 4baa1b3cb80..80cb6abe59d 100644 --- a/lisp/erc/erc-autoaway.el +++ b/lisp/erc/erc-autoaway.el @@ -82,7 +82,7 @@ This is used when `erc-autoaway-idle-method' is 'user." (unless (erc-autoaway-some-server-buffer) (remove-hook 'post-command-hook 'erc-autoaway-reset-idle-user))) -;;;###autoload (autoload 'erc-autoaway-mode "erc-autoaway") +;;;###autoload(autoload 'erc-autoaway-mode "erc-autoaway") (define-erc-module autoaway nil "In ERC autoaway mode, you can be set away automatically. If `erc-auto-set-away' is set, then you will be set away after @@ -282,6 +282,7 @@ active server buffer available." ;;; erc-autoaway.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index ca37ee8f0c9..7eec56e363b 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -644,22 +644,24 @@ Make sure you are in an ERC buffer when running this." (erc-log-irc-protocol line nil) (erc-parse-server-response process line))))))) -(defsubst erc-server-reconnect-p (event) +(define-inline erc-server-reconnect-p (event) "Return non-nil if ERC should attempt to reconnect automatically. EVENT is the message received from the closed connection process." - (or erc-server-reconnecting - (and erc-server-auto-reconnect - (not erc-server-banned) - ;; make sure we don't infinitely try to reconnect, unless the - ;; user wants that - (or (eq erc-server-reconnect-attempts t) - (and (integerp erc-server-reconnect-attempts) - (< erc-server-reconnect-count - erc-server-reconnect-attempts))) - (or erc-server-timed-out - (not (string-match "^deleted" event))) - ;; open-network-stream-nowait error for connection refused - (if (string-match "^failed with code 111" event) 'nonblocking t)))) + (inline-letevals (event) + (inline-quote + (or erc-server-reconnecting + (and erc-server-auto-reconnect + (not erc-server-banned) + ;; make sure we don't infinitely try to reconnect, unless the + ;; user wants that + (or (eq erc-server-reconnect-attempts t) + (and (integerp erc-server-reconnect-attempts) + (< erc-server-reconnect-count + erc-server-reconnect-attempts))) + (or erc-server-timed-out + (not (string-match "^deleted" ,event))) + ;; open-network-stream-nowait error for connection refused + (if (string-match "^failed with code 111" ,event) 'nonblocking t)))))) (defun erc-process-sentinel-2 (event buffer) "Called when `erc-process-sentinel-1' has detected an unexpected disconnect." diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el index cdc8046c086..8269e5c1634 100644 --- a/lisp/erc/erc-button.el +++ b/lisp/erc/erc-button.el @@ -49,7 +49,7 @@ "Define how text can be turned into clickable buttons." :group 'erc) -;;;###autoload (autoload 'erc-button-mode "erc-button" nil t) +;;;###autoload(autoload 'erc-button-mode "erc-button" nil t) (define-erc-module button nil "This mode buttonizes all messages according to `erc-button-alist'." ((add-hook 'erc-insert-modify-hook 'erc-button-add-buttons 'append) @@ -545,5 +545,6 @@ and `apropos' for other symbols." ;;; erc-button.el ends here ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: nil ;; End: diff --git a/lisp/erc/erc-capab.el b/lisp/erc/erc-capab.el index 278eaf2506f..85f18fd5e88 100644 --- a/lisp/erc/erc-capab.el +++ b/lisp/erc/erc-capab.el @@ -90,7 +90,7 @@ character not found in IRC nicknames to avoid confusion." ;;; Define module: -;;;###autoload (autoload 'erc-capab-identify-mode "erc-capab" nil t) +;;;###autoload(autoload 'erc-capab-identify-mode "erc-capab" nil t) (define-erc-module capab-identify nil "Handle dancer-ircd's CAPAB IDENTIFY-MSG and IDENTIFY-CTCP." ;; append so that `erc-server-parameters' is already set by `erc-server-005' @@ -207,3 +207,7 @@ PARSED is an `erc-parsed' response struct." (provide 'erc-capab) ;;; erc-capab.el ends here + +;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" +;; End: diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el index 15de703d803..ce66ff9007f 100644 --- a/lisp/erc/erc-compat.el +++ b/lisp/erc/erc-compat.el @@ -29,7 +29,7 @@ (require 'format-spec) -;;;###autoload (autoload 'erc-define-minor-mode "erc-compat") +;;;###autoload(autoload 'erc-define-minor-mode "erc-compat") (defalias 'erc-define-minor-mode 'define-minor-mode) (put 'erc-define-minor-mode 'edebug-form-spec 'define-minor-mode) @@ -161,6 +161,7 @@ If START or END is negative, it counts from the end." ;;; erc-compat.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el index 2ca6a92b66f..764c6cc6170 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el @@ -56,7 +56,7 @@ (require 'erc) (eval-when-compile (require 'pcomplete)) -;;;###autoload (autoload 'erc-dcc-mode "erc-dcc") +;;;###autoload(autoload 'erc-dcc-mode "erc-dcc") (define-erc-module dcc nil "Provide Direct Client-to-Client support for ERC." ((add-hook 'erc-server-401-functions 'erc-dcc-no-such-nick)) @@ -649,9 +649,10 @@ that subcommand." "\"\\(\\(.*?\\(\\\\\"\\)?\\)+?\\)\"\\|\\([^ ]+\\)" "\\) \\([0-9]+\\) \\([0-9]+\\) *\\([0-9]*\\)")) -(defsubst erc-dcc-unquote-filename (filename) - (erc-replace-regexp-in-string "\\\\\\\\" "\\" - (erc-replace-regexp-in-string "\\\\\"" "\"" filename t t) t t)) +(define-inline erc-dcc-unquote-filename (filename) + (inline-quote + (erc-replace-regexp-in-string "\\\\\\\\" "\\" + (erc-replace-regexp-in-string "\\\\\"" "\"" ,filename t t) t t))) (defun erc-dcc-handle-ctcp-send (proc query nick login host to) "This is called if a CTCP DCC SEND subcommand is sent to the client. @@ -780,8 +781,8 @@ unconfirmed." :group 'erc-dcc :type '(choice (const nil) integer)) -(defsubst erc-dcc-get-parent (proc) - (plist-get (erc-dcc-member :peer proc) :parent)) +(define-inline erc-dcc-get-parent (proc) + (inline-quote (plist-get (erc-dcc-member :peer ,proc) :parent))) (defun erc-dcc-send-block (proc) "Send one block of data. @@ -1257,5 +1258,6 @@ other client." ;;; erc-dcc.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: nil ;; End: diff --git a/lisp/erc/erc-desktop-notifications.el b/lisp/erc/erc-desktop-notifications.el index f44a6978031..84db0f58e46 100644 --- a/lisp/erc/erc-desktop-notifications.el +++ b/lisp/erc/erc-desktop-notifications.el @@ -98,3 +98,7 @@ This will replace the last notification sent with this function." (provide 'erc-desktop-notifications) ;;; erc-desktop-notifications.el ends here + +;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" +;; End: diff --git a/lisp/erc/erc-ezbounce.el b/lisp/erc/erc-ezbounce.el index e698cea847e..58697506185 100644 --- a/lisp/erc/erc-ezbounce.el +++ b/lisp/erc/erc-ezbounce.el @@ -175,3 +175,7 @@ in the alist is nil, prompt for the appropriate values." (provide 'erc-ezbounce) ;;; erc-ezbounce.el ends here + +;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" +;; End: diff --git a/lisp/erc/erc-fill.el b/lisp/erc/erc-fill.el index f980d356e25..5efb8540b61 100644 --- a/lisp/erc/erc-fill.el +++ b/lisp/erc/erc-fill.el @@ -37,7 +37,7 @@ "Filling means to reformat long lines in different ways." :group 'erc) -;;;###autoload (autoload 'erc-fill-mode "erc-fill" nil t) +;;;###autoload(autoload 'erc-fill-mode "erc-fill" nil t) (erc-define-minor-mode erc-fill-mode "Toggle ERC fill mode. With a prefix argument ARG, enable ERC fill mode if ARG is @@ -193,5 +193,6 @@ You can put this on `erc-insert-modify-hook' and/or `erc-send-modify-hook'." ;;; erc-fill.el ends here ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: nil ;; End: diff --git a/lisp/erc/erc-identd.el b/lisp/erc/erc-identd.el index d39a58df204..d710d95cde8 100644 --- a/lisp/erc/erc-identd.el +++ b/lisp/erc/erc-identd.el @@ -55,7 +55,7 @@ This can be either a string or a number." (integer :tag "Port number") (string :tag "Port string"))) -;;;###autoload (autoload 'erc-identd-mode "erc-identd") +;;;###autoload(autoload 'erc-identd-mode "erc-identd") (define-erc-module identd nil "This mode launches an identd server on port 8113." ((add-hook 'erc-connect-pre-hook 'erc-identd-quickstart) @@ -115,6 +115,7 @@ The default port is specified by `erc-identd-port'." ;;; erc-identd.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-imenu.el b/lisp/erc/erc-imenu.el index 05fe1c6738e..f038216cea6 100644 --- a/lisp/erc/erc-imenu.el +++ b/lisp/erc/erc-imenu.el @@ -131,6 +131,7 @@ Don't rely on this function, read it first!" ;;; erc-imenu.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-join.el b/lisp/erc/erc-join.el index a6bf6518ea8..d7ae93316cd 100644 --- a/lisp/erc/erc-join.el +++ b/lisp/erc/erc-join.el @@ -39,7 +39,7 @@ "Enable autojoining." :group 'erc) -;;;###autoload (autoload 'erc-autojoin-mode "erc-join" nil t) +;;;###autoload(autoload 'erc-autojoin-mode "erc-join" nil t) (define-erc-module autojoin nil "Makes ERC autojoin on connects and reconnects." ((add-hook 'erc-after-connect 'erc-autojoin-channels) @@ -215,6 +215,7 @@ This function is run from `erc-nickserv-identified-hook'." ;;; erc-join.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-list.el b/lisp/erc/erc-list.el index bdc51e77ae7..0bb962dece5 100644 --- a/lisp/erc/erc-list.el +++ b/lisp/erc/erc-list.el @@ -55,7 +55,7 @@ (defvar erc-list-server-buffer nil) ;; Define module: -;;;###autoload (autoload 'erc-list-mode "erc-list") +;;;###autoload(autoload 'erc-list-mode "erc-list") (define-erc-module list nil "List channels nicely in a separate buffer." ((remove-hook 'erc-server-321-functions 'erc-server-321-message) @@ -225,6 +225,7 @@ to RFC and send the LIST header (#321) at start of list transmission." ;;; erc-list.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-log.el b/lisp/erc/erc-log.el index 1f0cb13c0d0..de2fa16c50b 100644 --- a/lisp/erc/erc-log.el +++ b/lisp/erc/erc-log.el @@ -215,7 +215,7 @@ The function should take one argument, which is the text to filter." (const :tag "No filtering" nil))) -;;;###autoload (autoload 'erc-log-mode "erc-log" nil t) +;;;###autoload(autoload 'erc-log-mode "erc-log" nil t) (define-erc-module log nil "Automatically logs things you receive on IRC into files. Files are stored in `erc-log-channels-directory'; file name @@ -455,6 +455,7 @@ You can save every individual message by putting this function on ;;; erc-log.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el index c7ba5adace1..534a5b74205 100644 --- a/lisp/erc/erc-match.el +++ b/lisp/erc/erc-match.el @@ -44,7 +44,7 @@ Group containing all things concerning pattern matching in ERC messages." :group 'erc) -;;;###autoload (autoload 'erc-match-mode "erc-match") +;;;###autoload(autoload 'erc-match-mode "erc-match") (define-erc-module match nil "This mode checks whether messages match certain patterns. If so, they are hidden or highlighted. This is controlled via the variables @@ -648,6 +648,7 @@ This function is meant to be called from `erc-text-matched-hook'." ;;; erc-match.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-menu.el b/lisp/erc/erc-menu.el index e10a8e193d0..4270ec6d993 100644 --- a/lisp/erc/erc-menu.el +++ b/lisp/erc/erc-menu.el @@ -107,7 +107,7 @@ "Internal variable used to keep track of whether we've defined the ERC menu yet.") -;;;###autoload (autoload 'erc-menu-mode "erc-menu" nil t) +;;;###autoload(autoload 'erc-menu-mode "erc-menu" nil t) (define-erc-module menu nil "Enable a menu in ERC buffers." ((unless erc-menu-defined @@ -148,6 +148,7 @@ ERC menu yet.") ;;; erc-menu.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-netsplit.el b/lisp/erc/erc-netsplit.el index 0eedd54dde7..885fc49bce5 100644 --- a/lisp/erc/erc-netsplit.el +++ b/lisp/erc/erc-netsplit.el @@ -38,7 +38,7 @@ netsplit happens, and filters the QUIT messages. It also keeps track of netsplits, so that it can filter the JOIN messages on a netjoin too." :group 'erc) -;;;###autoload (autoload 'erc-netsplit-mode "erc-netsplit") +;;;###autoload(autoload 'erc-netsplit-mode "erc-netsplit") (define-erc-module netsplit nil "This mode hides quit/join messages if a netsplit occurs." ((erc-netsplit-install-message-catalogs) @@ -205,6 +205,7 @@ join from that split has been detected or not.") ;;; erc-netsplit.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-notify.el b/lisp/erc/erc-notify.el index 267aecdbb0d..2666598436a 100644 --- a/lisp/erc/erc-notify.el +++ b/lisp/erc/erc-notify.el @@ -92,7 +92,7 @@ strings." (notify_on . "Detected %n on IRC network %m") (notify_off . "%n has left IRC network %m")))) -;;;###autoload (autoload 'erc-notify-mode "erc-notify" nil t) +;;;###autoload(autoload 'erc-notify-mode "erc-notify" nil t) (define-erc-module notify nil "Periodically check for the online status of certain users and report changes." @@ -253,6 +253,7 @@ with args, toggle notify status of people." ;;; erc-notify.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-page.el b/lisp/erc/erc-page.el index e47f471641f..4d78a8c7214 100644 --- a/lisp/erc/erc-page.el +++ b/lisp/erc/erc-page.el @@ -30,7 +30,7 @@ (require 'erc) -;;;###autoload (autoload 'erc-page-mode "erc-page") +;;;###autoload(autoload 'erc-page-mode "erc-page") (define-erc-module page ctcp-page "Process CTCP PAGE requests from IRC." nil nil) @@ -107,6 +107,7 @@ receive pages if `erc-page-mode' is on." ;;; erc-page.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-pcomplete.el b/lisp/erc/erc-pcomplete.el index 64b535d78e1..db0359c9afc 100644 --- a/lisp/erc/erc-pcomplete.el +++ b/lisp/erc/erc-pcomplete.el @@ -60,7 +60,7 @@ the most recent speakers are listed first." :group 'erc-pcomplete :type 'boolean) -;;;###autoload (autoload 'erc-completion-mode "erc-pcomplete" nil t) +;;;###autoload(autoload 'erc-completion-mode "erc-pcomplete" nil t) (define-erc-module pcomplete Completion "In ERC Completion mode, the TAB key does completion whenever possible." ((add-hook 'erc-mode-hook 'pcomplete-erc-setup) @@ -284,5 +284,6 @@ up to where point is right now." ;;; erc-pcomplete.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: nil ;; End: diff --git a/lisp/erc/erc-replace.el b/lisp/erc/erc-replace.el index 4efb9a74b9e..f321ae0228d 100644 --- a/lisp/erc/erc-replace.el +++ b/lisp/erc/erc-replace.el @@ -77,7 +77,7 @@ It replaces text according to `erc-replace-alist'." (eval to)))))) erc-replace-alist)) -;;;###autoload (autoload 'erc-replace-mode "erc-replace") +;;;###autoload(autoload 'erc-replace-mode "erc-replace") (define-erc-module replace nil "This mode replaces incoming text according to `erc-replace-alist'." ((add-hook 'erc-insert-modify-hook @@ -90,6 +90,7 @@ It replaces text according to `erc-replace-alist'." ;;; erc-replace.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-ring.el b/lisp/erc/erc-ring.el index 5a7282dd965..7e315d3b6ed 100644 --- a/lisp/erc/erc-ring.el +++ b/lisp/erc/erc-ring.el @@ -42,7 +42,7 @@ "An input ring for ERC." :group 'erc) -;;;###autoload (autoload 'erc-ring-mode "erc-ring" nil t) +;;;###autoload(autoload 'erc-ring-mode "erc-ring" nil t) (define-erc-module ring nil "Stores input in a ring so that previous commands and messages can be recalled using M-p and M-n." @@ -146,5 +146,6 @@ containing a password." ;;; erc-ring.el ends here ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: nil ;; End: diff --git a/lisp/erc/erc-services.el b/lisp/erc/erc-services.el index 75ae9b51912..62201b0e7cf 100644 --- a/lisp/erc/erc-services.el +++ b/lisp/erc/erc-services.el @@ -1,4 +1,4 @@ -;;; erc-services.el --- Identify to NickServ +;;; erc-services.el --- Identify to NickServ -*- lexical-binding:t -*- ;; Copyright (C) 2002-2004, 2006-2018 Free Software Foundation, Inc. @@ -89,7 +89,7 @@ Possible settings are:. latter. nil - Disables automatic Nickserv identification. -You can also use M-x erc-nickserv-identify-mode to change modes." +You can also use \\[erc-nickserv-identify-mode] to change modes." :group 'erc-services :type '(choice (const autodetect) (const nick-change) @@ -101,7 +101,7 @@ You can also use M-x erc-nickserv-identify-mode to change modes." (when (featurep 'erc-services) (erc-nickserv-identify-mode val)))) -;;;###autoload (autoload 'erc-services-mode "erc-services" nil t) +;;;###autoload(autoload 'erc-services-mode "erc-services" nil t) (define-erc-module services nickserv "This mode automates communication with services." ((erc-nickserv-identify-mode erc-nickserv-identify-mode)) @@ -312,26 +312,33 @@ The last two elements are optional." (const :tag "Do not try to detect success" nil))))) -(defsubst erc-nickserv-alist-sender (network &optional entry) - (nth 1 (or entry (assoc network erc-nickserv-alist)))) +(define-inline erc-nickserv-alist-sender (network &optional entry) + (inline-letevals (network entry) + (inline-quote (nth 1 (or ,entry (assoc ,network erc-nickserv-alist)))))) -(defsubst erc-nickserv-alist-regexp (network &optional entry) - (nth 2 (or entry (assoc network erc-nickserv-alist)))) +(define-inline erc-nickserv-alist-regexp (network &optional entry) + (inline-letevals (network entry) + (inline-quote (nth 2 (or ,entry (assoc ,network erc-nickserv-alist)))))) -(defsubst erc-nickserv-alist-nickserv (network &optional entry) - (nth 3 (or entry (assoc network erc-nickserv-alist)))) +(define-inline erc-nickserv-alist-nickserv (network &optional entry) + (inline-letevals (network entry) + (inline-quote (nth 3 (or ,entry (assoc ,network erc-nickserv-alist)))))) -(defsubst erc-nickserv-alist-ident-keyword (network &optional entry) - (nth 4 (or entry (assoc network erc-nickserv-alist)))) +(define-inline erc-nickserv-alist-ident-keyword (network &optional entry) + (inline-letevals (network entry) + (inline-quote (nth 4 (or ,entry (assoc ,network erc-nickserv-alist)))))) -(defsubst erc-nickserv-alist-use-nick-p (network &optional entry) - (nth 5 (or entry (assoc network erc-nickserv-alist)))) +(define-inline erc-nickserv-alist-use-nick-p (network &optional entry) + (inline-letevals (network entry) + (inline-quote (nth 5 (or ,entry (assoc ,network erc-nickserv-alist)))))) -(defsubst erc-nickserv-alist-ident-command (network &optional entry) - (nth 6 (or entry (assoc network erc-nickserv-alist)))) +(define-inline erc-nickserv-alist-ident-command (network &optional entry) + (inline-letevals (network entry) + (inline-quote (nth 6 (or ,entry (assoc ,network erc-nickserv-alist)))))) -(defsubst erc-nickserv-alist-identified-regexp (network &optional entry) - (nth 7 (or entry (assoc network erc-nickserv-alist)))) +(define-inline erc-nickserv-alist-identified-regexp (network &optional entry) + (inline-letevals (network entry) + (inline-quote (nth 7 (or ,entry (assoc ,network erc-nickserv-alist)))))) ;; Functions: @@ -341,7 +348,7 @@ Hooks are called with arguments (NETWORK NICK)." :group 'erc-services :type 'hook) -(defun erc-nickserv-identification-autodetect (proc parsed) +(defun erc-nickserv-identification-autodetect (_proc parsed) "Check for NickServ's successful identification notice. Make sure it is the real NickServ for this network and that it has specifically confirmed a successful identification attempt. @@ -361,7 +368,7 @@ If this is the case, run `erc-nickserv-identified-hook'." (run-hook-with-args 'erc-nickserv-identified-hook network nick) nil))) -(defun erc-nickserv-identify-autodetect (proc parsed) +(defun erc-nickserv-identify-autodetect (_proc parsed) "Identify to NickServ when an identify request is received. Make sure it is the real NickServ for this network. If `erc-prompt-for-nickserv-password' is non-nil, prompt the user for the @@ -383,7 +390,7 @@ password for this nickname, otherwise try to send it automatically." (erc-nickserv-call-identify-function nick) nil)))) -(defun erc-nickserv-identify-on-connect (server nick) +(defun erc-nickserv-identify-on-connect (_server nick) "Identify to Nickserv after the connection to the server is established." (unless (or (and (null erc-nickserv-passwords) (null erc-prompt-for-nickserv-password)) @@ -391,7 +398,7 @@ password for this nickname, otherwise try to send it automatically." (erc-nickserv-alist-regexp (erc-network)))) (erc-nickserv-call-identify-function nick))) -(defun erc-nickserv-identify-on-nick-change (nick old-nick) +(defun erc-nickserv-identify-on-nick-change (nick _old-nick) "Identify to Nickserv whenever your nick changes." (unless (or (and (null erc-nickserv-passwords) (null erc-prompt-for-nickserv-password)) @@ -400,9 +407,9 @@ password for this nickname, otherwise try to send it automatically." (erc-nickserv-call-identify-function nick))) (defun erc-nickserv-call-identify-function (nickname) - "Call `erc-nickserv-identify' interactively or run it with NICKNAME's -password. -The action is determined by the value of `erc-prompt-for-nickserv-password'." + "Call `erc-nickserv-identify'. +Either call it interactively or run it with NICKNAME's password, +depending on the value of `erc-prompt-for-nickserv-password'." (if erc-prompt-for-nickserv-password (call-interactively 'erc-nickserv-identify) (when erc-nickserv-passwords @@ -411,6 +418,8 @@ The action is determined by the value of `erc-prompt-for-nickserv-password'." (nth 1 (assoc (erc-network) erc-nickserv-passwords)))))))) +(defvar erc-auto-discard-away) + ;;;###autoload (defun erc-nickserv-identify (password) "Send an \"identify <PASSWORD>\" message to NickServ. @@ -444,6 +453,7 @@ When called interactively, read the password using `read-passwd'." ;;; erc-services.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-sound.el b/lisp/erc/erc-sound.el index e68668c5d03..8df8ded44f3 100644 --- a/lisp/erc/erc-sound.el +++ b/lisp/erc/erc-sound.el @@ -46,7 +46,7 @@ (require 'erc) -;;;###autoload (autoload 'erc-sound-mode "erc-sound") +;;;###autoload(autoload 'erc-sound-mode "erc-sound") (define-erc-module sound ctcp-sound "In ERC sound mode, the client will respond to CTCP SOUND requests and play sound files as requested." @@ -145,6 +145,7 @@ See also `play-sound-file'." ;;; erc-sound.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-speedbar.el b/lisp/erc/erc-speedbar.el index 109ef281d36..58eefd83cfb 100644 --- a/lisp/erc/erc-speedbar.el +++ b/lisp/erc/erc-speedbar.el @@ -361,6 +361,7 @@ The INDENT level is ignored." ;;; erc-speedbar.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-spelling.el b/lisp/erc/erc-spelling.el index 89f75f13aa2..3a34ea37397 100644 --- a/lisp/erc/erc-spelling.el +++ b/lisp/erc/erc-spelling.el @@ -33,7 +33,7 @@ (require 'erc) (require 'flyspell) -;;;###autoload (autoload 'erc-spelling-mode "erc-spelling" nil t) +;;;###autoload(autoload 'erc-spelling-mode "erc-spelling" nil t) (define-erc-module spelling nil "Enable flyspell mode in ERC buffers." ;; Use erc-connect-pre-hook instead of erc-mode-hook as pre-hook is @@ -109,3 +109,7 @@ The cadr is the beginning and the caddr is the end." (provide 'erc-spelling) ;;; erc-spelling.el ends here + +;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" +;; End: diff --git a/lisp/erc/erc-stamp.el b/lisp/erc/erc-stamp.el index 17ee2cb17d0..6a648e74358 100644 --- a/lisp/erc/erc-stamp.el +++ b/lisp/erc/erc-stamp.el @@ -158,7 +158,7 @@ from entering them and instead jump over them." "ERC timestamp face." :group 'erc-faces) -;;;###autoload (autoload 'erc-timestamp-mode "erc-stamp" nil t) +;;;###autoload(autoload 'erc-timestamp-mode "erc-stamp" nil t) (define-erc-module stamp timestamp "This mode timestamps messages in the channel buffers." ((add-hook 'erc-mode-hook #'erc-munge-invisibility-spec) @@ -417,6 +417,7 @@ enabled when the message was inserted." ;;; erc-stamp.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el index a45777cb773..7817a0799ef 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -542,7 +542,7 @@ keybindings will not do anything useful." ;;; Module -;;;###autoload (autoload 'erc-track-mode "erc-track" nil t) +;;;###autoload(autoload 'erc-track-mode "erc-track" nil t) (define-erc-module track nil "This mode tracks ERC channel buffers with activity." ;; Enable: @@ -974,6 +974,7 @@ switch back to the last non-ERC buffer visited. Next is defined by ;;; erc-track.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-truncate.el b/lisp/erc/erc-truncate.el index 37744ebfd44..d4359c5c6b3 100644 --- a/lisp/erc/erc-truncate.el +++ b/lisp/erc/erc-truncate.el @@ -43,7 +43,7 @@ Used only when auto-truncation is enabled. :group 'erc-truncate :type 'integer) -;;;###autoload (autoload 'erc-truncate-mode "erc-truncate" nil t) +;;;###autoload(autoload 'erc-truncate-mode "erc-truncate" nil t) (define-erc-module truncate nil "Truncate a query buffer if it gets too large. This prevents the query buffer from getting too large, which can @@ -112,6 +112,7 @@ Meant to be used in hooks, like `erc-insert-post-hook'." ;;; erc-truncate.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc-xdcc.el b/lisp/erc/erc-xdcc.el index 4f1ebe4fad0..0d66fe51069 100644 --- a/lisp/erc/erc-xdcc.el +++ b/lisp/erc/erc-xdcc.el @@ -61,7 +61,7 @@ being evaluated and should return strings." :group 'erc-dcc :type '(repeat (repeat :tag "Message" (choice string sexp)))) -;;;###autoload (autoload 'erc-xdcc-mode "erc-xdcc") +;;;###autoload(autoload 'erc-xdcc-mode "erc-xdcc") (define-erc-module xdcc nil "Act as an XDCC file-server." nil nil) @@ -133,6 +133,7 @@ being evaluated and should return strings." ;;; erc-xdcc.el ends here ;; ;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" ;; indent-tabs-mode: t ;; tab-width: 8 ;; End: diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index dbf3dac0941..550800c57f2 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -67,6 +67,8 @@ ;;; Code: +(load "erc-loaddefs" nil t) + (eval-when-compile (require 'cl-lib)) (require 'font-lock) (require 'pp) @@ -399,25 +401,28 @@ If no server buffer exists, return nil." ;; This is useful for ordered name completion. (last-message-time nil)) -(defsubst erc-get-channel-user (nick) +(define-inline erc-get-channel-user (nick) "Find the (USER . CHANNEL-DATA) element corresponding to NICK in the current buffer's `erc-channel-users' hash table." - (gethash (erc-downcase nick) erc-channel-users)) + (inline-quote (gethash (erc-downcase ,nick) erc-channel-users))) -(defsubst erc-get-server-user (nick) +(define-inline erc-get-server-user (nick) "Find the USER corresponding to NICK in the current server's `erc-server-users' hash table." - (erc-with-server-buffer - (gethash (erc-downcase nick) erc-server-users))) + (inline-letevals (nick) + (inline-quote (erc-with-server-buffer + (gethash (erc-downcase ,nick) erc-server-users))))) -(defsubst erc-add-server-user (nick user) +(define-inline erc-add-server-user (nick user) "This function is for internal use only. Adds USER with nickname NICK to the `erc-server-users' hash table." - (erc-with-server-buffer - (puthash (erc-downcase nick) user erc-server-users))) + (inline-letevals (nick user) + (inline-quote + (erc-with-server-buffer + (puthash (erc-downcase ,nick) ,user erc-server-users))))) -(defsubst erc-remove-server-user (nick) +(define-inline erc-remove-server-user (nick) "This function is for internal use only. Removes the user with nickname NICK from the `erc-server-users' @@ -425,8 +430,10 @@ hash table. This user is not removed from the `erc-channel-users' lists of other buffers. See also: `erc-remove-user'." - (erc-with-server-buffer - (remhash (erc-downcase nick) erc-server-users))) + (inline-letevals (nick) + (inline-quote + (erc-with-server-buffer + (remhash (erc-downcase ,nick) erc-server-users))))) (defun erc-change-user-nickname (user new-nick) "This function is for internal use only. @@ -497,45 +504,55 @@ Removes all users in the current channel. This is called by erc-channel-users) (clrhash erc-channel-users))) -(defsubst erc-channel-user-owner-p (nick) +(define-inline erc-channel-user-owner-p (nick) "Return non-nil if NICK is an owner of the current channel." - (and nick - (hash-table-p erc-channel-users) - (let ((cdata (erc-get-channel-user nick))) - (and cdata (cdr cdata) - (erc-channel-user-owner (cdr cdata)))))) - -(defsubst erc-channel-user-admin-p (nick) + (inline-letevals (nick) + (inline-quote + (and ,nick + (hash-table-p erc-channel-users) + (let ((cdata (erc-get-channel-user ,nick))) + (and cdata (cdr cdata) + (erc-channel-user-owner (cdr cdata)))))))) + +(define-inline erc-channel-user-admin-p (nick) "Return non-nil if NICK is an admin in the current channel." - (and nick + (inline-letevals (nick) + (inline-quote + (and ,nick (hash-table-p erc-channel-users) - (let ((cdata (erc-get-channel-user nick))) + (let ((cdata (erc-get-channel-user ,nick))) (and cdata (cdr cdata) - (erc-channel-user-admin (cdr cdata)))))) + (erc-channel-user-admin (cdr cdata)))))))) -(defsubst erc-channel-user-op-p (nick) +(define-inline erc-channel-user-op-p (nick) "Return non-nil if NICK is an operator in the current channel." - (and nick + (inline-letevals (nick) + (inline-quote + (and ,nick (hash-table-p erc-channel-users) - (let ((cdata (erc-get-channel-user nick))) + (let ((cdata (erc-get-channel-user ,nick))) (and cdata (cdr cdata) - (erc-channel-user-op (cdr cdata)))))) + (erc-channel-user-op (cdr cdata)))))))) -(defsubst erc-channel-user-halfop-p (nick) +(define-inline erc-channel-user-halfop-p (nick) "Return non-nil if NICK is a half-operator in the current channel." - (and nick + (inline-letevals (nick) + (inline-quote + (and ,nick (hash-table-p erc-channel-users) - (let ((cdata (erc-get-channel-user nick))) + (let ((cdata (erc-get-channel-user ,nick))) (and cdata (cdr cdata) - (erc-channel-user-halfop (cdr cdata)))))) + (erc-channel-user-halfop (cdr cdata)))))))) -(defsubst erc-channel-user-voice-p (nick) +(define-inline erc-channel-user-voice-p (nick) "Return non-nil if NICK has voice in the current channel." - (and nick + (inline-letevals (nick) + (inline-quote + (and ,nick (hash-table-p erc-channel-users) - (let ((cdata (erc-get-channel-user nick))) + (let ((cdata (erc-get-channel-user ,nick))) (and cdata (cdr cdata) - (erc-channel-user-voice (cdr cdata)))))) + (erc-channel-user-voice (cdr cdata)))))))) (defun erc-get-channel-user-list () "Return a list of users in the current channel. Each element @@ -1260,7 +1277,7 @@ erc-NAME-enable, and erc-NAME-disable. Example: - ;;;###autoload (autoload \\='erc-replace-mode \"erc-replace\") + ;;;###autoload(autoload \\='erc-replace-mode \"erc-replace\") (define-erc-module replace nil \"This mode replaces incoming text according to `erc-replace-alist'.\" ((add-hook \\='erc-insert-modify-hook @@ -1343,10 +1360,11 @@ capabilities." (add-hook hook fun nil t) fun)) -(defsubst erc-log (string) +(define-inline erc-log (string) "Logs STRING if logging is on (see `erc-log-p')." - (when erc-log-p - (erc-log-aux string))) + (inline-quote + (when erc-log-p + (erc-log-aux ,string)))) (defun erc-server-buffer () "Return the server buffer for the current buffer's process. @@ -2549,9 +2567,7 @@ consumption for long-lived IRC or Emacs sessions." (maphash (lambda (nick last-PRIVMSG-time) (when - (> (float-time (time-subtract - (current-time) - last-PRIVMSG-time)) + (> (float-time (time-subtract nil last-PRIVMSG-time)) erc-lurker-threshold-time) (remhash nick hash))) hash) @@ -2618,7 +2634,7 @@ server within `erc-lurker-threshold-time'. See also (gethash server erc-lurker-state (make-hash-table))))) (or (null last-PRIVMSG-time) (> (float-time - (time-subtract (current-time) last-PRIVMSG-time)) + (time-subtract nil last-PRIVMSG-time)) erc-lurker-threshold-time)))) (defcustom erc-common-server-suffixes diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el index 3f863171bd9..62e2f57d0fd 100644 --- a/lisp/eshell/em-hist.el +++ b/lisp/eshell/em-hist.el @@ -218,9 +218,6 @@ Returns nil if INPUT is prepended by blank space, otherwise non-nil." (defun eshell-hist-initialize () "Initialize the history management code for one Eshell buffer." - (add-hook 'eshell-expand-input-functions - 'eshell-expand-history-references nil t) - (when (eshell-using-module 'eshell-cmpl) (add-hook 'pcomplete-try-first-hook 'eshell-complete-history-reference nil t)) @@ -584,21 +581,30 @@ See also `eshell-read-history'." (defun eshell-expand-history-references (beg end) "Parse and expand any history references in current input." - (let ((result (eshell-hist-parse-arguments beg end))) + (let ((result (eshell-hist-parse-arguments beg end)) + (full-line (buffer-substring-no-properties beg end))) (when result (let ((textargs (nreverse (nth 0 result))) (posb (nreverse (nth 1 result))) - (pose (nreverse (nth 2 result)))) + (pose (nreverse (nth 2 result))) + (full-line-subst (eshell-history-substitution full-line))) (save-excursion - (while textargs - (let ((str (eshell-history-reference (car textargs)))) - (unless (eq str (car textargs)) - (goto-char (car posb)) - (insert-and-inherit str) - (delete-char (- (car pose) (car posb))))) - (setq textargs (cdr textargs) - posb (cdr posb) - pose (cdr pose)))))))) + (if full-line-subst + ;; Found a ^foo^bar substitution + (progn + (goto-char beg) + (insert-and-inherit full-line-subst) + (delete-char (- end beg))) + ;; Try to expand other substitutions + (while textargs + (let ((str (eshell-history-reference (car textargs)))) + (unless (eq str (car textargs)) + (goto-char (car posb)) + (insert-and-inherit str) + (delete-char (- (car pose) (car posb))))) + (setq textargs (cdr textargs) + posb (cdr posb) + pose (cdr pose))))))))) (defvar pcomplete-stub) (defvar pcomplete-last-completion-raw) @@ -633,20 +639,31 @@ See also `eshell-read-history'." (setq history (cdr history))) (cdr fhist))))))) +(defun eshell-history-substitution (line) + "Expand quick hist substitutions formatted as ^foo^bar^. +Returns nil if string does not match quick substitution format, +and acts like !!:s/foo/bar/ otherwise." + ;; `^string1^string2^' + ;; Quick Substitution. Repeat the last command, replacing + ;; STRING1 with STRING2. Equivalent to `!!:s/string1/string2/' + (when (and (eshell-using-module 'eshell-pred) + (string-match + "^\\^\\([^^]+\\)\\^\\([^^]+\\)\\(?:\\^\\(.*\\)\\)?$" + line)) + ;; Save trailing match as `eshell-history-reference' runs string-match. + (let ((matched-end (match-string 3 line))) + (concat + (eshell-history-reference + (format "!!:s/%s/%s/" + (match-string 1 line) + (match-string 2 line))) + matched-end)))) + (defun eshell-history-reference (reference) "Expand directory stack REFERENCE. The syntax used here was taken from the Bash info manual. Returns the resultant reference, or the same string REFERENCE if none matched." - ;; `^string1^string2^' - ;; Quick Substitution. Repeat the last command, replacing - ;; STRING1 with STRING2. Equivalent to `!!:s/string1/string2/' - (if (and (eshell-using-module 'eshell-pred) - (string-match "\\^\\([^^]+\\)\\^\\([^^]+\\)\\^?\\s-*$" - reference)) - (setq reference (format "!!:s/%s/%s/" - (match-string 1 reference) - (match-string 2 reference)))) ;; `!' ;; Start a history substitution, except when followed by a ;; space, tab, the end of the line, = or (. diff --git a/lisp/eshell/em-pred.el b/lisp/eshell/em-pred.el index 2c12cacfff8..61af4048d54 100644 --- a/lisp/eshell/em-pred.el +++ b/lisp/eshell/em-pred.el @@ -545,7 +545,8 @@ that `ls -l' will show in the first column of its display. " (function (lambda (str) (if (string-match ,match str) - (setq str (replace-match ,replace t nil str))) + (setq str (replace-match ,replace t nil str)) + (error (concat str ": substitution failed"))) str)) lst))))) (defun eshell-include-members (&optional invert-p) diff --git a/lisp/filecache.el b/lisp/filecache.el index eaf2cfc92e0..9dd631001da 100644 --- a/lisp/filecache.el +++ b/lisp/filecache.el @@ -1,4 +1,4 @@ -;;; filecache.el --- find files using a pre-loaded cache +;;; filecache.el --- find files using a pre-loaded cache -*- lexical-binding:t -*- ;; Copyright (C) 1996, 2000-2018 Free Software Foundation, Inc. @@ -25,16 +25,16 @@ ;; ;; The file-cache package is an attempt to make it easy to locate files ;; by name, without having to remember exactly where they are located. -;; This is very handy when working with source trees. You can also add +;; This is very handy when working with source trees. You can also add ;; frequently used files to the cache to create a hotlist effect. ;; The cache can be used with any interactive command which takes a ;; filename as an argument. ;; ;; It is worth noting that this package works best when most of the files ;; in the cache have unique names, or (if they have the same name) exist in -;; only a few directories. The worst case is many files all with +;; only a few directories. The worst case is many files all with ;; the same name and in different directories, for example a big source tree -;; with a Makefile in each directory. In such a case, you should probably +;; with a Makefile in each directory. In such a case, you should probably ;; use an alternate strategy to find the files. ;; ;; ADDING FILES TO THE CACHE: @@ -49,11 +49,11 @@ ;; `file-cache-delete-regexps' to eliminate unwanted files: ;; ;; * `file-cache-add-directory': Adds the files in a directory to the -;; cache. You can also specify a regular expression to match the files +;; cache. You can also specify a regular expression to match the files ;; which should be added. ;; ;; * `file-cache-add-directory-list': Same as above, but acts on a list -;; of directories. You can use `load-path', `exec-path' and the like. +;; of directories. You can use `load-path', `exec-path' and the like. ;; ;; * `file-cache-add-directory-using-find': Uses the `find' command to ;; add a directory tree to the cache. @@ -65,7 +65,7 @@ ;; add all files matching a pattern to the cache. ;; ;; Use the function `file-cache-clear-cache' to remove all items from the -;; cache. There are a number of `file-cache-delete' functions provided +;; cache. There are a number of `file-cache-delete' functions provided ;; as well, but in general it is probably better to not worry too much ;; about extra files in the cache. ;; @@ -76,7 +76,7 @@ ;; FINDING FILES USING THE CACHE: ;; ;; You can use the file-cache with any function that expects a filename as -;; an argument. For example: +;; an argument. For example: ;; ;; 1) Invoke a function which expects a filename as an argument: ;; M-x find-file @@ -160,13 +160,11 @@ File names which match these expressions will not be added to the cache. Note that the functions `file-cache-add-file' and `file-cache-add-file-list' do not use this variable." :version "25.1" ; added "/\\.#" - :type '(repeat regexp) - :group 'file-cache) + :type '(repeat regexp)) (defcustom file-cache-find-command "find" "External program used by `file-cache-add-directory-using-find'." - :type 'string - :group 'file-cache) + :type 'string) (defcustom file-cache-find-command-posix-flag 'not-defined "Set to t, if `file-cache-find-command' handles wildcards POSIX style. @@ -178,30 +176,25 @@ Under Windows operating system where Cygwin is available, this value should be t." :type '(choice (const :tag "Yes" t) (const :tag "No" nil) - (const :tag "Unknown" not-defined)) - :group 'file-cache) + (const :tag "Unknown" not-defined))) (defcustom file-cache-locate-command "locate" "External program used by `file-cache-add-directory-using-locate'." - :type 'string - :group 'file-cache) + :type 'string) ;; Minibuffer messages (defcustom file-cache-no-match-message " [File Cache: No match]" "Message to display when there is no completion." - :type 'string - :group 'file-cache) + :type 'string) (defcustom file-cache-sole-match-message " [File Cache: sole completion]" "Message to display when there is only one completion." - :type 'string - :group 'file-cache) + :type 'string) (defcustom file-cache-non-unique-message " [File Cache: complete but not unique]" "Message to display when there is a non-unique completion." - :type 'string - :group 'file-cache) + :type 'string) (defcustom file-cache-completion-ignore-case (if (memq system-type '(ms-dos windows-nt cygwin)) @@ -209,8 +202,7 @@ should be t." completion-ignore-case) "If non-nil, file-cache completion should ignore case. Defaults to the value of `completion-ignore-case'." - :type 'boolean - :group 'file-cache) + :type 'boolean) (defcustom file-cache-case-fold-search (if (memq system-type '(ms-dos windows-nt cygwin)) @@ -218,15 +210,13 @@ Defaults to the value of `completion-ignore-case'." case-fold-search) "If non-nil, file-cache completion should ignore case. Defaults to the value of `case-fold-search'." - :type 'boolean - :group 'file-cache) + :type 'boolean) (defcustom file-cache-ignore-case (memq system-type '(ms-dos windows-nt cygwin)) "Non-nil means ignore case when checking completions in the file cache. Defaults to nil on DOS and Windows, and t on other systems." - :type 'boolean - :group 'file-cache) + :type 'boolean) (defvar file-cache-multiple-directory-message nil) @@ -235,18 +225,10 @@ Defaults to nil on DOS and Windows, and t on other systems." ;; switch-to-completions in simple.el expects (defcustom file-cache-completions-buffer "*Completions*" "Buffer to display completions when using the file cache." - :type 'string - :group 'file-cache) + :type 'string) -(defcustom file-cache-buffer "*File Cache*" - "Buffer to hold the cache of file names." - :type 'string - :group 'file-cache) - -(defcustom file-cache-buffer-default-regexp "^.+$" - "Regexp to match files in `file-cache-buffer'." - :type 'regexp - :group 'file-cache) +(defvar file-cache-buffer-default-regexp "^.+$" + "Regexp to match files in find and locate's output.") (defvar file-cache-last-completion nil) @@ -362,36 +344,31 @@ Find is run in DIRECTORY." (if (eq file-cache-find-command-posix-flag 'not-defined) (setq file-cache-find-command-posix-flag (executable-command-find-posix-p file-cache-find-command)))) - (set-buffer (get-buffer-create file-cache-buffer)) - (erase-buffer) - (call-process file-cache-find-command nil - (get-buffer file-cache-buffer) nil - dir "-name" - (if (memq system-type '(windows-nt cygwin)) - (if file-cache-find-command-posix-flag - "\\*" - "'*'") - "*") - "-print") - (file-cache-add-from-file-cache-buffer))) + (with-temp-buffer + (call-process file-cache-find-command nil t nil + dir "-name" + (if (memq system-type '(windows-nt cygwin)) + (if file-cache-find-command-posix-flag + "\\*" + "'*'") + "*") + "-print") + (file-cache--add-from-buffer)))) ;;;###autoload (defun file-cache-add-directory-using-locate (string) "Use the `locate' command to add files to the file cache. STRING is passed as an argument to the locate command." (interactive "sAdd files using locate string: ") - (set-buffer (get-buffer-create file-cache-buffer)) - (erase-buffer) - (call-process file-cache-locate-command nil - (get-buffer file-cache-buffer) nil - string) - (file-cache-add-from-file-cache-buffer)) + (with-temp-buffer + (call-process file-cache-locate-command nil t nil string) + (file-cache--add-from-buffer))) (autoload 'find-lisp-find-files "find-lisp") ;;;###autoload (defun file-cache-add-directory-recursively (dir &optional regexp) - "Adds DIR and any subdirectories to the file-cache. + "Add DIR and any subdirectories to the file-cache. This function does not use any external programs. If the optional REGEXP argument is non-nil, only files which match it will be added to the cache. Note that the REGEXP is applied to the @@ -408,22 +385,16 @@ files in each directory, not to the directory list itself." (file-cache-add-file file))) (find-lisp-find-files dir (or regexp "^")))) -(defun file-cache-add-from-file-cache-buffer (&optional regexp) - "Add any entries found in the file cache buffer. +(defun file-cache--add-from-buffer () + "Add any entries found in the current buffer. Each entry matches the regular expression `file-cache-buffer-default-regexp' or the optional REGEXP argument." - (set-buffer file-cache-buffer) (dolist (elt file-cache-filter-regexps) (goto-char (point-min)) (delete-matching-lines elt)) (goto-char (point-min)) - (let ((full-filename)) - (while (re-search-forward - (or regexp file-cache-buffer-default-regexp) - (point-max) t) - (setq full-filename (buffer-substring-no-properties - (match-beginning 0) (match-end 0))) - (file-cache-add-file full-filename)))) + (while (re-search-forward file-cache-buffer-default-regexp nil t) + (file-cache-add-file (match-string-no-properties 0)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Functions to delete from the cache @@ -566,68 +537,65 @@ the directories that the name is available in. With a prefix argument, the name is considered already unique; only the second substitution \(directories) is done." (interactive "P") - (let* - ( - (completion-ignore-case file-cache-completion-ignore-case) - (case-fold-search file-cache-case-fold-search) - (string (file-name-nondirectory (minibuffer-contents))) - (completion-string (try-completion string file-cache-alist)) - (completion-list) - (len) - (file-cache-string)) + (let* ((completion-ignore-case file-cache-completion-ignore-case) + (case-fold-search file-cache-case-fold-search) + (string (file-name-nondirectory (minibuffer-contents))) + (completion (completion-try-completion + string file-cache-alist nil 0))) (cond ;; If it's the only match, replace the original contents - ((or arg (eq completion-string t)) - (setq file-cache-string (file-cache-file-name string)) - (if (string= file-cache-string (minibuffer-contents)) - (minibuffer-message file-cache-sole-match-message) - (delete-minibuffer-contents) - (insert file-cache-string) - (if file-cache-multiple-directory-message - (minibuffer-message file-cache-multiple-directory-message)))) + ((or arg (eq completion t)) + (let ((file-name (file-cache-file-name string))) + (if (string= file-name (minibuffer-contents)) + (minibuffer-message file-cache-sole-match-message) + (delete-minibuffer-contents) + (insert file-name) + (if file-cache-multiple-directory-message + (minibuffer-message file-cache-multiple-directory-message))))) ;; If it's the longest match, insert it - ((stringp completion-string) - ;; If we've already inserted a unique string, see if the user - ;; wants to use that one - (if (and (string= string completion-string) - (assoc-string string file-cache-alist - file-cache-ignore-case)) - (if (and (eq last-command this-command) - (string= file-cache-last-completion completion-string)) - (progn - (delete-minibuffer-contents) - (insert (file-cache-file-name completion-string)) - (setq file-cache-last-completion nil)) - (minibuffer-message file-cache-non-unique-message) - (setq file-cache-last-completion string)) - (setq file-cache-last-completion string) - (setq completion-list (all-completions string file-cache-alist) - len (length completion-list)) - (if (> len 1) - (progn - (goto-char (point-max)) - (insert - (substring completion-string (length string))) - ;; Add our own setup function to the Completions Buffer - (let ((completion-setup-hook - (append completion-setup-hook - (list 'file-cache-completion-setup-function)))) - (with-output-to-temp-buffer file-cache-completions-buffer - (display-completion-list - (completion-hilit-commonality completion-list - (length string)))))) - (setq file-cache-string (file-cache-file-name completion-string)) - (if (string= file-cache-string (minibuffer-contents)) - (minibuffer-message file-cache-sole-match-message) - (delete-minibuffer-contents) - (insert file-cache-string) - (if file-cache-multiple-directory-message - (minibuffer-message file-cache-multiple-directory-message))) - ))) + ((consp completion) + (let ((newstring (car completion)) + (newpoint (cdr completion))) + ;; If we've already inserted a unique string, see if the user + ;; wants to use that one + (if (and (string= string newstring) + (assoc-string string file-cache-alist + file-cache-ignore-case)) + (if (and (eq last-command this-command) + (string= file-cache-last-completion newstring)) + (progn + (delete-minibuffer-contents) + (insert (file-cache-file-name newstring)) + (setq file-cache-last-completion nil)) + (minibuffer-message file-cache-non-unique-message) + (setq file-cache-last-completion string)) + (setq file-cache-last-completion string) + (let* ((completion-list (completion-all-completions + newstring file-cache-alist nil newpoint)) + (base-size (cdr (last completion-list)))) + (when base-size + (setcdr (last completion-list) nil)) + (if (> (length completion-list) 1) + (progn + (delete-region (- (point-max) (length string)) (point-max)) + (save-excursion (insert newstring)) + (forward-char newpoint) + (with-output-to-temp-buffer file-cache-completions-buffer + (display-completion-list completion-list) + ;; Add our own setup function to the Completions Buffer + (file-cache-completion-setup-function))) + (let ((file-name (file-cache-file-name newstring))) + (if (string= file-name (minibuffer-contents)) + (minibuffer-message file-cache-sole-match-message) + (delete-minibuffer-contents) + (insert file-name) + (if file-cache-multiple-directory-message + (minibuffer-message + file-cache-multiple-directory-message))))))))) ;; No match - ((eq completion-string nil) + ((eq completion nil) (minibuffer-message file-cache-no-match-message))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -647,7 +615,7 @@ the name is considered already unique; only the second substitution (file-cache-minibuffer-complete nil))) (define-obsolete-function-alias 'file-cache-mouse-choose-completion - 'file-cache-choose-completion "23.2") + #'file-cache-choose-completion "23.2") (defun file-cache-complete () "Complete the word at point, using the filecache." diff --git a/lisp/files.el b/lisp/files.el index 66420e7259d..5b8dff71310 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -1801,7 +1801,11 @@ killed." (setq buffer-file-truename nil) ;; Likewise for dired buffers. (setq dired-directory nil) - (find-file filename wildcards)) + ;; Don't use `find-file' because it may end up using another window + ;; in some corner cases, e.g. when the selected window is + ;; softly-dedicated. + (let ((newbuf (find-file-noselect filename wildcards))) + (switch-to-buffer newbuf))) (when (eq obuf (current-buffer)) ;; This executes if find-file gets an error ;; and does not really find anything. @@ -4521,8 +4525,8 @@ extension, the value is \"\"." ""))))) (defun file-name-base (&optional filename) - "Return the base name of the FILENAME: no directory, no extension. -FILENAME defaults to `buffer-file-name'." + "Return the base name of the FILENAME: no directory, no extension." + (declare (advertised-calling-convention (filename) "27.1")) (file-name-sans-extension (file-name-nondirectory (or filename (buffer-file-name))))) @@ -5903,7 +5907,11 @@ an auto-save file." (error "%s is an auto-save file" (abbreviate-file-name file))) (let ((file-name (let ((buffer-file-name file)) (make-auto-save-file-name)))) - (cond ((if (file-exists-p file) + (cond ((and (file-exists-p file) + (not (file-exists-p file-name))) + (error "Auto save file %s does not exist" + (abbreviate-file-name file-name))) + ((if (file-exists-p file) (not (file-newer-than-file-p file-name file)) (not (file-exists-p file-name))) (error "Auto-save file %s not current" @@ -6435,58 +6443,31 @@ if you want to specify options, use `directory-free-space-args'. A value of nil disables this feature. -If the function `file-system-info' is defined, it is always used in -preference to the program given by this variable." +This variable is obsolete; Emacs no longer uses it." :type '(choice (string :tag "Program") (const :tag "None" nil)) :group 'dired) +(make-obsolete-variable 'directory-free-space-program + "ignored, as Emacs uses `file-system-info' instead" + "27.1") (defcustom directory-free-space-args (purecopy (if (eq system-type 'darwin) "-k" "-Pk")) "Options to use when running `directory-free-space-program'." :type 'string :group 'dired) +(make-obsolete-variable 'directory-free-space-args + "ignored, as Emacs uses `file-system-info' instead" + "27.1") (defun get-free-disk-space (dir) "Return the amount of free space on directory DIR's file system. The return value is a string describing the amount of free space (normally, the number of free 1KB blocks). -This function calls `file-system-info' if it is available, or -invokes the program specified by `directory-free-space-program' -and `directory-free-space-args'. If the system call or program -is unsuccessful, or if DIR is a remote directory, this function -returns nil." - (unless (file-remote-p (expand-file-name dir)) - ;; Try to find the number of free blocks. Non-Posix systems don't - ;; always have df, but might have an equivalent system call. - (if (fboundp 'file-system-info) - (let ((fsinfo (file-system-info dir))) - (if fsinfo - (format "%.0f" (/ (nth 2 fsinfo) 1024)))) - (setq dir (expand-file-name dir)) - (save-match-data - (with-temp-buffer - (when (and directory-free-space-program - ;; Avoid failure if the default directory does - ;; not exist (Bug#2631, Bug#3911). - (let ((default-directory - (locate-dominating-file dir 'file-directory-p))) - (eq (process-file directory-free-space-program - nil t nil - directory-free-space-args - (file-relative-name dir)) - 0))) - ;; Assume that the "available" column is before the - ;; "capacity" column. Find the "%" and scan backward. - (goto-char (point-min)) - (forward-line 1) - (when (re-search-forward - "[[:space:]]+[^[:space:]]+%[^%]*$" - (line-end-position) t) - (goto-char (match-beginning 0)) - (let ((endpt (point))) - (skip-chars-backward "^[:space:]") - (buffer-substring-no-properties (point) endpt))))))))) +If DIR's free space cannot be obtained, this function returns nil." + (let ((avail (nth 2 (file-system-info dir)))) + (if avail + (format "%.0f" (/ avail 1024))))) ;; The following expression replaces `dired-move-to-filename-regexp'. (defvar directory-listing-before-filename-regexp diff --git a/lisp/find-dired.el b/lisp/find-dired.el index 4dda3c425c3..ebd14b07579 100644 --- a/lisp/find-dired.el +++ b/lisp/find-dired.el @@ -295,7 +295,7 @@ specifies what to use in place of \"-ls\" as the final argument." (l-opt (and (consp find-ls-option) (string-match "l" (cdr find-ls-option)))) (ls-regexp (concat "^ +[^ \t\r\n]+\\( +[^ \t\r\n]+\\) +" - "[^ \t\r\n]+ +[^ \t\r\n]+\\( +[0-9]+\\)"))) + "[^ \t\r\n]+ +[^ \t\r\n]+\\( +[^[:space:]]+\\)"))) (goto-char beg) (insert string) (goto-char beg) diff --git a/lisp/format.el b/lisp/format.el index 9f109e1aa1e..2f198e3eb71 100644 --- a/lisp/format.el +++ b/lisp/format.el @@ -84,7 +84,7 @@ iso-sgml2iso iso-iso2sgml t nil) (rot13 ,(purecopy "rot13") nil - ,(purecopy "tr a-mn-z n-za-m") ,(purecopy "tr a-mn-z n-za-m") t nil) + rot13-region rot13-region t nil) (duden ,(purecopy "Duden Ersatzdarstellung") nil ,(purecopy "diac") iso-iso2duden t nil) diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index 5dd4eaab9a5..c786a9c82de 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -1108,7 +1108,7 @@ downloadable." gnus-newsgroup-cached) (setq articles (gnus-sorted-ndifference (gnus-sorted-ndifference - (gnus-copy-sequence articles) + (copy-tree articles) gnus-newsgroup-downloadable) gnus-newsgroup-cached))) @@ -1123,7 +1123,7 @@ downloadable." (when gnus-newsgroup-processable (setq gnus-newsgroup-downloadable (let* ((dl gnus-newsgroup-downloadable) - (processable (sort (gnus-copy-sequence gnus-newsgroup-processable) '<)) + (processable (sort (copy-tree gnus-newsgroup-processable) '<)) (gnus-newsgroup-downloadable processable)) (gnus-agent-summary-fetch-group) @@ -1513,7 +1513,7 @@ downloaded into the agent." (let* ((fetched-articles (list nil)) (tail-fetched-articles fetched-articles) (dir (gnus-agent-group-pathname group)) - (date (time-to-days (current-time))) + (date (time-to-days nil)) (case-fold-search t) pos crosses (file-name-coding-system nnmail-pathname-coding-system)) @@ -2833,7 +2833,7 @@ The following commands are available: "Copy the current category." (interactive (list (gnus-category-name) (intern (read-string "New name: ")))) (let ((info (assq category gnus-category-alist))) - (push (let ((newcat (gnus-copy-sequence info))) + (push (let ((newcat (copy-tree info))) (setf (gnus-agent-cat-name newcat) to) (setf (gnus-agent-cat-groups newcat) nil) newcat) @@ -3089,7 +3089,7 @@ FORCE is equivalent to setting the expiration predicates to true." (nov-entries-deleted 0) (info (gnus-get-info group)) (alist gnus-agent-article-alist) - (day (- (time-to-days (current-time)) + (day (- (time-to-days nil) (gnus-agent-find-parameter group 'agent-days-until-old))) (specials (if (and alist (not force)) @@ -3824,7 +3824,7 @@ has been fetched." ;; be expired later. (gnus-agent-load-alist group) (gnus-agent-save-alist group (list article) - (time-to-days (current-time)))))) + (time-to-days nil))))) (defun gnus-agent-regenerate-group (group &optional reread) "Regenerate GROUP. diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 79b2ade62b2..cf1ec25f96b 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -3628,8 +3628,7 @@ possible values." (defun article-lapsed-string (time &optional max-segments) ;; If the date is seriously mangled, the timezone functions are ;; liable to bug out, so we ignore all errors. - (let* ((now (current-time)) - (real-time (time-subtract now time)) + (let* ((real-time (time-subtract nil time)) (real-sec (and real-time (+ (* (float (car real-time)) 65536) (cadr real-time)))) @@ -5220,7 +5219,7 @@ available media-types." (gnus-completing-read "View as MIME type" (if pred - (gnus-remove-if-not pred (mailcap-mime-types)) + (seq-filter pred (mailcap-mime-types)) (mailcap-mime-types)) nil nil nil (car default))))) diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el index c5a2575b9ad..d1324fef633 100644 --- a/lisp/gnus/gnus-cache.el +++ b/lisp/gnus/gnus-cache.el @@ -735,7 +735,7 @@ If LOW, update the lower bound instead." ;; `gnus-cache-unified-group-names' needless. (gnus-sethash (or (cdr (assoc group gnus-cache-unified-group-names)) group) - (cons (car nums) (gnus-last-element nums)) + (cons (car nums) (car (last nums))) gnus-cache-active-hashtb)) ;; Go through all the other files. (dolist (file alphs) diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el index 284fdca494e..2693c01dcba 100644 --- a/lisp/gnus/gnus-cloud.el +++ b/lisp/gnus/gnus-cloud.el @@ -76,7 +76,7 @@ (defcustom gnus-cloud-method nil "The IMAP select method used to store the cloud data. -See also `gnus-server-toggle-cloud-method-server' for an +See also `gnus-server-set-cloud-method-server' for an easy interactive way to set this from the Server buffer." :group 'gnus-cloud :type '(radio (const :tag "Not set" nil) @@ -225,7 +225,7 @@ easy interactive way to set this from the Server buffer." Use old data if FORCE-OLDER is not nil." (let* ((contents (plist-get elem :contents)) (date (or (plist-get elem :timestamp) "0")) - (now (gnus-cloud-timestamp (current-time))) + (now (gnus-cloud-timestamp nil)) (newer (string-lessp date now)) (group-info (gnus-get-info group))) (if (and contents @@ -492,7 +492,7 @@ Otherwise, returns the Gnus Cloud data chunks." (gnus-method-to-server (gnus-find-method-for-group (gnus-info-group info)))) - (push `(:type :newsrc-data :name ,(gnus-info-group info) :contents ,info :timestamp ,(gnus-cloud-timestamp (current-time))) + (push `(:type :newsrc-data :name ,(gnus-info-group info) :contents ,info :timestamp ,(gnus-cloud-timestamp nil)) infos))) infos)) diff --git a/lisp/gnus/gnus-cus.el b/lisp/gnus/gnus-cus.el index d265fd5245e..00ccfb7e3dd 100644 --- a/lisp/gnus/gnus-cus.el +++ b/lisp/gnus/gnus-cus.el @@ -406,7 +406,7 @@ category.")) ;; every duplicate ends up being displayed. So, rather than ;; display them, remove them from the list. - (let ((tmp (setq values (gnus-copy-sequence values))) + (let ((tmp (setq values (copy-tree values))) elem) (while (cdr tmp) (while (setq elem (assq (caar tmp) (cdr tmp))) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index fea09ea21a5..48dbc82889e 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -1359,6 +1359,8 @@ if it is a string, only list groups matching REGEXP." (and gnus-permanently-visible-groups (string-match gnus-permanently-visible-groups group)) + ;; Marked groups are always visible. + (member group gnus-group-marked) (memq 'visible params) (cdr (assq 'visible params))))))) (gnus-group-insert-group-line @@ -2998,7 +3000,7 @@ and NEW-NAME will be prompted for." ;; Set the info. (if (not (and info new-group)) (gnus-group-set-info form (or new-group group) part) - (setq info (gnus-copy-sequence info)) + (setq info (copy-tree info)) (setcar info new-group) (unless (gnus-server-equal method "native") (unless (nthcdr 3 info) @@ -3021,7 +3023,7 @@ and NEW-NAME will be prompted for." ;; Don't use `caddr' here since macros within the `interactive' ;; form won't be expanded. (car (cddr entry))))) - (setq method (gnus-copy-sequence method)) + (setq method (copy-tree method)) (let (entry) (while (setq entry (memq (assq 'eval method) method)) (setcar entry (eval (cadar entry))))) @@ -4565,7 +4567,7 @@ or `gnus-group-catchup-group-hook'." "Return the offset in seconds from the timestamp for GROUP to the current time, as a floating point number." (let* ((time (or (gnus-group-timestamp group) (list 0 0))) - (delta (time-subtract (current-time) time))) + (delta (time-subtract nil time))) (+ (* (nth 0 delta) 65536.0) (nth 1 delta)))) diff --git a/lisp/gnus/gnus-html.el b/lisp/gnus/gnus-html.el index fc0b36b0db1..5d07a823f61 100644 --- a/lisp/gnus/gnus-html.el +++ b/lisp/gnus/gnus-html.el @@ -99,11 +99,7 @@ fit these criteria." (not (file-exists-p (url-cache-create-filename url)))) (t (let ((cache-time (url-is-cached url))) (if cache-time - (time-less-p - (time-add - cache-time - ttl) - (current-time)) + (time-less-p (time-add cache-time ttl) nil) t))))) ;;;###autoload diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el index d878e7695a9..48cffdb7388 100644 --- a/lisp/gnus/gnus-icalendar.el +++ b/lisp/gnus/gnus-icalendar.el @@ -169,7 +169,7 @@ (defun gnus-icalendar-event--get-attendee-names (ical) (let* ((event (car (icalendar--all-events ical))) - (attendee-props (gnus-remove-if-not + (attendee-props (seq-filter (lambda (p) (eq (car p) 'ATTENDEE)) (caddr event)))) @@ -180,7 +180,7 @@ (or (plist-get (cadr prop) 'CN) (replace-regexp-in-string "^.*MAILTO:" "" (caddr prop)))) (attendees-by-type (type) - (gnus-remove-if-not + (seq-filter (lambda (p) (string= (attendee-role p) type)) attendee-props)) (attendee-names-by-type diff --git a/lisp/gnus/gnus-range.el b/lisp/gnus/gnus-range.el index c8ba7ae5c15..32433816e4c 100644 --- a/lisp/gnus/gnus-range.el +++ b/lisp/gnus/gnus-range.el @@ -38,17 +38,9 @@ If RANGE is a single range, return (RANGE). Otherwise, return RANGE." (while (cdr list) (setq list (cdr list))) (car list)) +(make-obsolete 'gnus-last-element "use `car' of `last' instead." "27.1") -(defun gnus-copy-sequence (list) - "Do a complete, total copy of a list." - (let (out) - (while (consp list) - (if (consp (car list)) - (push (gnus-copy-sequence (pop list)) out) - (push (pop list) out))) - (if list - (nconc (nreverse out) list) - (nreverse out)))) +(define-obsolete-function-alias 'gnus-copy-sequence 'copy-tree "27.1") (defun gnus-set-difference (list1 list2) "Return a list of elements of LIST1 that do not appear in LIST2." @@ -455,7 +447,7 @@ modified." (if (or (null range1) (null range2)) range1 (let (out r1 r2 r1_min r1_max r2_min r2_max - (range2 (gnus-copy-sequence range2))) + (range2 (copy-tree range2))) (setq range1 (if (listp (cdr range1)) range1 (list range1)) range2 (sort (if (listp (cdr range2)) range2 (list range2)) (lambda (e1 e2) diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index 4c0d5218ab8..07e80f3ca96 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -844,21 +844,17 @@ Addresses without a name will say \"noname\"." nil)) (defun gnus-registry-fetch-sender-fast (article) - (gnus-registry-fetch-header-fast "from" article)) + (when-let* ((data (and (numberp article) + (assoc article (gnus-data-list nil))))) + (mail-header-from (gnus-data-header data)))) (defun gnus-registry-fetch-recipients-fast (article) - (gnus-registry-sort-addresses - (or (ignore-errors (gnus-registry-fetch-header-fast "Cc" article)) "") - (or (ignore-errors (gnus-registry-fetch-header-fast "To" article)) ""))) - -(defun gnus-registry-fetch-header-fast (article header) - "Fetch the HEADER quickly, using the internal gnus-data-list function." - (if (and (numberp article) - (assoc article (gnus-data-list nil))) - (gnus-string-remove-all-properties - (cdr (assq header (gnus-data-header - (assoc article (gnus-data-list nil)))))) - nil)) + (when-let* ((data (and (numberp article) + (assoc article (gnus-data-list nil)))) + (extra (mail-header-extra (gnus-data-header data)))) + (gnus-registry-sort-addresses + (or (cdr (assq 'Cc extra)) "") + (or (cdr (assq 'To extra)) "")))) ;; registry marks glue (defun gnus-registry-do-marks (type function) diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el index a6536797662..ec07d1ab15a 100644 --- a/lisp/gnus/gnus-score.el +++ b/lisp/gnus/gnus-score.el @@ -921,7 +921,7 @@ EXTRA is the possible non-standard header." (interactive (list (gnus-completing-read "Header" (mapcar 'car - (gnus-remove-if-not + (seq-filter (lambda (x) (fboundp (nth 2 x))) gnus-header-index)) t) @@ -1078,11 +1078,11 @@ EXTRA is the possible non-standard header." "Return the score of the current article. With prefix ARG, return the total score of the current (sub)thread." (interactive "P") - (gnus-message 1 "%s" (if arg - (gnus-thread-total-score - (gnus-id-to-thread - (mail-header-id (gnus-summary-article-header)))) - (gnus-summary-article-score)))) + (message "%s" (if arg + (gnus-thread-total-score + (gnus-id-to-thread + (mail-header-id (gnus-summary-article-header)))) + (gnus-summary-article-score)))) (defun gnus-score-change-score-file (file) "Change current score alist." @@ -1238,7 +1238,7 @@ If FORMAT, also format the current score file." (or (not decay) (gnus-decay-scores alist decay))) (gnus-score-set 'touched '(t) alist) - (gnus-score-set 'decay (list (time-to-days (current-time))) alist)) + (gnus-score-set 'decay (list (time-to-days nil)) alist)) ;; We do not respect eval and files atoms from global score ;; files. (when (and files (not global)) @@ -2318,7 +2318,7 @@ score in `gnus-newsgroup-scored' by SCORE." (when (or (not (listp gnus-newsgroup-adaptive)) (memq 'line gnus-newsgroup-adaptive)) (save-excursion - (let* ((malist (gnus-copy-sequence gnus-adaptive-score-alist)) + (let* ((malist (copy-tree gnus-adaptive-score-alist)) (alist malist) (date (current-time-string)) (data gnus-newsgroup-data) @@ -2731,8 +2731,10 @@ GROUP using BNews sys file syntax." (insert (car sfiles)) (goto-char (point-min)) ;; First remove the suffix itself. - (when (re-search-forward (concat "." score-regexp) nil t) - (replace-match "" t t) + (when (re-search-forward score-regexp nil t) + (unless (= (match-end 0) (match-beginning 0)) ; non-empty suffix + (replace-match "" t t) + (delete-char -1)) ; remove the "." before the suffix (goto-char (point-min)) (if (looking-at (regexp-quote kill-dir)) ;; If the file name was just "SCORE", `klen' is one character @@ -3060,7 +3062,7 @@ If ADAPT, return the home adaptive file instead." (defun gnus-decay-scores (alist day) "Decay non-permanent scores in ALIST." - (let ((times (- (time-to-days (current-time)) day)) + (let ((times (- (time-to-days nil) day)) kill entry updated score n) (unless (zerop times) ;Done decays today already? (while (setq entry (pop alist)) diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index f9795628cc0..9ba7a15c912 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -142,7 +142,7 @@ If nil, a faster, but more primitive, buffer is used instead." ["Offline" gnus-server-offline-server t] ["Deny" gnus-server-deny-server t] ["Toggle Cloud Sync for this server" gnus-server-toggle-cloud-server t] - ["Toggle Cloud Sync Host" gnus-server-toggle-cloud-method-server t] + ["Toggle Cloud Sync Host" gnus-server-set-cloud-method-server t] "---" ["Open All" gnus-server-open-all-servers t] ["Close All" gnus-server-close-all-servers t] @@ -189,7 +189,7 @@ If nil, a faster, but more primitive, buffer is used instead." "z" gnus-server-compact-server "i" gnus-server-toggle-cloud-server - "I" gnus-server-toggle-cloud-method-server + "I" gnus-server-set-cloud-method-server "\C-c\C-i" gnus-info-find-node "\C-c\C-b" gnus-bug)) @@ -452,7 +452,8 @@ The following commands are available: (if server (error "No such server: %s" server) (error "No server on the current line"))) (unless (assoc server gnus-server-alist) - (error "Read-only server %s" server)) + (error "Server %s must be deleted from your configuration files" + server)) (gnus-dribble-touch) (let ((buffer-read-only nil)) (gnus-delete-line)) @@ -608,7 +609,7 @@ The following commands are available: (error "%s already exists" to)) (unless (gnus-server-to-method from) (error "%s: no such server" from)) - (let ((to-entry (cons from (gnus-copy-sequence + (let ((to-entry (cons from (copy-tree (gnus-server-to-method from))))) (setcar to-entry to) (setcar (nthcdr 2 to-entry) to) @@ -642,7 +643,8 @@ The following commands are available: (unless server (error "No server on current line")) (unless (assoc server gnus-server-alist) - (error "This server can't be edited")) + (error "Server %s must be edited in your configuration files" + server)) (let ((info (cdr (assoc server gnus-server-alist)))) (gnus-close-server info) (gnus-edit-form @@ -1127,7 +1129,7 @@ Requesting compaction of %s... (this may take a long time)" (and original (gnus-kill-buffer original)))))) (defun gnus-server-toggle-cloud-server () - "Make the server under point be replicated in the Emacs Cloud." + "Toggle whether the server under point is replicated in the Emacs Cloud." (interactive) (let ((server (gnus-server-server-name))) (unless server @@ -1147,7 +1149,7 @@ Requesting compaction of %s... (this may take a long time)" "Replication of %s in the cloud will stop") server))) -(defun gnus-server-toggle-cloud-method-server () +(defun gnus-server-set-cloud-method-server () "Set the server under point to host the Emacs Cloud." (interactive) (let ((server (gnus-server-server-name))) @@ -1157,7 +1159,7 @@ Requesting compaction of %s... (this may take a long time)" (error "The server under point can't host the Emacs Cloud")) (when (not (string-equal gnus-cloud-method server)) - (custom-set-variables '(gnus-cloud-method server)) + (customize-set-variable 'gnus-cloud-method server) ;; Note we can't use `Custom-save' here. (when (gnus-yes-or-no-p (format "The new cloud host server is %S now. Save it? " server)) diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index a39af45e92e..b6e9ea91b62 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -1266,9 +1266,13 @@ For example: ((1 . cn-gb-2312) (2 . big5))." :type 'boolean :group 'gnus-summary-marks) -(defcustom gnus-alter-articles-to-read-function nil - "Function to be called to alter the list of articles to be selected." - :type '(choice (const nil) function) +(defcustom gnus-alter-articles-to-read-function + (lambda (_group article-list) article-list) + "Function to be called to alter the list of articles to be selected. +This option defaults to a lambda form that simply returns the +list of articles unchanged. Use `add-function' to set one or +more custom filter functions." + :type 'function :group 'gnus-summary) (defcustom gnus-orphan-score nil @@ -3992,7 +3996,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (spam-initialize)) ;; Save the active value in effect when the group was entered. (setq gnus-newsgroup-active - (gnus-copy-sequence + (copy-tree (gnus-active gnus-newsgroup-name))) (setq gnus-newsgroup-highest (cdr gnus-newsgroup-active)) ;; You can change the summary buffer in some way with this hook. @@ -5737,7 +5741,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (mail-header-number (car gnus-newsgroup-headers)) gnus-newsgroup-end (mail-header-number - (gnus-last-element gnus-newsgroup-headers)))) + (car (last gnus-newsgroup-headers))))) ;; GROUP is successfully selected. (or gnus-newsgroup-headers t))))) @@ -5914,7 +5918,7 @@ If SELECT-ARTICLES, only select those articles from GROUP." (setq articles (nthcdr (- number select) articles)))) (setq gnus-newsgroup-unselected (gnus-sorted-difference gnus-newsgroup-unreads articles)) - (when gnus-alter-articles-to-read-function + (when (functionp gnus-alter-articles-to-read-function) (setq articles (sort (funcall gnus-alter-articles-to-read-function @@ -6076,12 +6080,12 @@ If SELECT-ARTICLES, only select those articles from GROUP." (del (gnus-list-range-intersection gnus-newsgroup-articles - (gnus-remove-from-range (gnus-copy-sequence old) list))) + (gnus-remove-from-range (copy-tree old) list))) (add (gnus-list-range-intersection gnus-newsgroup-articles (gnus-remove-from-range - (gnus-copy-sequence list) old)))) + (copy-tree list) old)))) (when add (push (list add 'add (list (cdr type))) delta-marks)) (when del @@ -11962,7 +11966,7 @@ Argument REVERSE means reverse order." (interactive "P") (gnus-summary-sort 'chars reverse)) -(defun gnus-summary-sort-by-mark (&optional reverse) +(defun gnus-summary-sort-by-marks (&optional reverse) "Sort the summary buffer by article marks. Argument REVERSE means reverse order." (interactive "P") @@ -12270,21 +12274,27 @@ save those articles instead." (if (> (length articles) 1) (format "these %d articles" (length articles)) "this article"))) + valid-names (to-newsgroup - (cond - ((null split-name) - (gnus-group-completing-read - prom - (gnus-remove-if-not 'gnus-valid-move-group-p gnus-active-hashtb t) - nil prefix nil default)) - ((= 1 (length split-name)) - (gnus-group-completing-read - prom - (gnus-remove-if-not 'gnus-valid-move-group-p gnus-active-hashtb t) - nil prefix 'gnus-group-history (car split-name))) - (t - (gnus-completing-read - prom (nreverse split-name) nil nil 'gnus-group-history)))) + (progn + (mapatoms (lambda (g) + (when (gnus-valid-move-group-p g) + (push g valid-names))) + gnus-active-hashtb) + (cond + ((null split-name) + (gnus-group-completing-read + prom + valid-names + nil prefix nil default)) + ((= 1 (length split-name)) + (gnus-group-completing-read + prom + valid-names + nil prefix 'gnus-group-history (car split-name))) + (t + (gnus-completing-read + prom (nreverse split-name) nil nil 'gnus-group-history))))) (to-method (gnus-server-to-method (gnus-group-method to-newsgroup))) encoded) (when to-newsgroup @@ -12915,7 +12925,7 @@ returned." (mail-header-number (car gnus-newsgroup-headers)) gnus-newsgroup-end (mail-header-number - (gnus-last-element gnus-newsgroup-headers)))) + (car (last gnus-newsgroup-headers))))) (when gnus-use-scoring (gnus-possibly-score-headers)))) @@ -13002,7 +13012,7 @@ If ALL is a number, fetch this number of articles." i new) (unless new-active (error "Couldn't fetch new data")) - (setq gnus-newsgroup-active (gnus-copy-sequence new-active)) + (setq gnus-newsgroup-active (copy-tree new-active)) (setq i (cdr gnus-newsgroup-active) gnus-newsgroup-highest i) (while (> i old-high) diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el index 0ff25ecd3b5..ddaace9a24d 100644 --- a/lisp/gnus/gnus-topic.el +++ b/lisp/gnus/gnus-topic.el @@ -220,6 +220,8 @@ If RECURSIVE is t, return groups in its subtopics too." ;; Check for permanent visibility. (and gnus-permanently-visible-groups (string-match gnus-permanently-visible-groups group)) + ;; Marked groups are always visible. + (member group gnus-group-marked) (memq 'visible params) (cdr (assq 'visible params))) ;; Add this group to the list of visible groups. @@ -458,7 +460,7 @@ If LOWEST is non-nil, list all newsgroups of level LOWEST or higher." (unless gnus-killed-hashtb (gnus-make-hashtable-from-killed)) (gnus-group-prepare-flat-list-dead - (gnus-remove-if (lambda (group) + (seq-remove (lambda (group) (or (gnus-group-entry group) (gnus-gethash group gnus-killed-hashtb))) not-in-list) diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 1c42d7d0ef8..8983132bfb3 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -1117,41 +1117,9 @@ ARG is passed to the first function." (with-current-buffer gnus-group-buffer (eq major-mode 'gnus-group-mode)))) -(defun gnus-remove-if (predicate sequence &optional hash-table-p) - "Return a copy of SEQUENCE with all items satisfying PREDICATE removed. -SEQUENCE should be a list, a vector, or a string. Returns always a list. -If HASH-TABLE-P is non-nil, regards SEQUENCE as a hash table." - (let (out) - (if hash-table-p - (mapatoms (lambda (symbol) - (unless (funcall predicate symbol) - (push symbol out))) - sequence) - (unless (listp sequence) - (setq sequence (append sequence nil))) - (while sequence - (unless (funcall predicate (car sequence)) - (push (car sequence) out)) - (setq sequence (cdr sequence)))) - (nreverse out))) - -(defun gnus-remove-if-not (predicate sequence &optional hash-table-p) - "Return a copy of SEQUENCE with all items not satisfying PREDICATE removed. -SEQUENCE should be a list, a vector, or a string. Returns always a list. -If HASH-TABLE-P is non-nil, regards SEQUENCE as a hash table." - (let (out) - (if hash-table-p - (mapatoms (lambda (symbol) - (when (funcall predicate symbol) - (push symbol out))) - sequence) - (unless (listp sequence) - (setq sequence (append sequence nil))) - (while sequence - (when (funcall predicate (car sequence)) - (push (car sequence) out)) - (setq sequence (cdr sequence)))) - (nreverse out))) +(define-obsolete-function-alias 'gnus-remove-if 'seq-remove "27.1") + +(define-obsolete-function-alias 'gnus-remove-if-not 'seq-filter "27.1") (defun gnus-grep-in-list (word list) "Find if a WORD matches any regular expression in the given LIST." diff --git a/lisp/gnus/gnus-win.el b/lisp/gnus/gnus-win.el index 28fd66ca75e..fd0c7181951 100644 --- a/lisp/gnus/gnus-win.el +++ b/lisp/gnus/gnus-win.el @@ -513,7 +513,7 @@ should have point." (memq frame '(t 0 visible))) (car (let ((frames (frames-on-display-list))) - (gnus-remove-if (lambda (win) (not (memq (window-frame win) + (seq-remove (lambda (win) (not (memq (window-frame win) frames))) (get-buffer-window-list buffer nil frame))))) (t diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 1448ba2df39..0ed5491ead5 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -1,4 +1,4 @@ -;;; gnus.el --- a newsreader for GNU Emacs +;;; gnus.el --- a newsreader for GNU Emacs -*- lexical-binding:t -*- ;; Copyright (C) 1987-1990, 1993-1998, 2000-2018 Free Software ;; Foundation, Inc. @@ -29,10 +29,11 @@ (run-hooks 'gnus-load-hook) -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'wid-edit) (require 'mm-util) (require 'nnheader) +(require 'seq) ;; These are defined afterwards with gnus-define-group-parameter (defvar gnus-ham-process-destinations) @@ -335,21 +336,6 @@ be set in `.emacs' instead." ;; We define these group faces here to avoid the display ;; update forced when creating new faces. -(defface gnus-group-news-1 - '((((class color) - (background dark)) - (:foreground "PaleTurquoise" :bold t)) - (((class color) - (background light)) - (:foreground "ForestGreen" :bold t)) - (t - ())) - "Level 1 newsgroup face." - :group 'gnus-group) -;; backward-compatibility alias -(put 'gnus-group-news-1-face 'face-alias 'gnus-group-news-1) -(put 'gnus-group-news-1-face 'obsolete-face "22.1") - (defface gnus-group-news-1-empty '((((class color) (background dark)) @@ -365,25 +351,18 @@ be set in `.emacs' instead." (put 'gnus-group-news-1-empty-face 'face-alias 'gnus-group-news-1-empty) (put 'gnus-group-news-1-empty-face 'obsolete-face "22.1") -(defface gnus-group-news-2 - '((((class color) - (background dark)) - (:foreground "turquoise" :bold t)) - (((class color) - (background light)) - (:foreground "CadetBlue4" :bold t)) - (t - ())) - "Level 2 newsgroup face." +(defface gnus-group-news-1 + '((t (:inherit gnus-group-news-1-empty :bold t))) + "Level 1 newsgroup face." :group 'gnus-group) ;; backward-compatibility alias -(put 'gnus-group-news-2-face 'face-alias 'gnus-group-news-2) -(put 'gnus-group-news-2-face 'obsolete-face "22.1") +(put 'gnus-group-news-1-face 'face-alias 'gnus-group-news-1) +(put 'gnus-group-news-1-face 'obsolete-face "22.1") (defface gnus-group-news-2-empty '((((class color) (background dark)) - (:foreground "turquoise")) + (:foreground "turquoise4")) (((class color) (background light)) (:foreground "CadetBlue4")) @@ -395,28 +374,21 @@ be set in `.emacs' instead." (put 'gnus-group-news-2-empty-face 'face-alias 'gnus-group-news-2-empty) (put 'gnus-group-news-2-empty-face 'obsolete-face "22.1") -(defface gnus-group-news-3 - '((((class color) - (background dark)) - (:bold t)) - (((class color) - (background light)) - (:bold t)) - (t - ())) - "Level 3 newsgroup face." +(defface gnus-group-news-2 + '((t (:inherit gnus-group-news-2-empty :bold t))) + "Level 2 newsgroup face." :group 'gnus-group) ;; backward-compatibility alias -(put 'gnus-group-news-3-face 'face-alias 'gnus-group-news-3) -(put 'gnus-group-news-3-face 'obsolete-face "22.1") +(put 'gnus-group-news-2-face 'face-alias 'gnus-group-news-2) +(put 'gnus-group-news-2-face 'obsolete-face "22.1") (defface gnus-group-news-3-empty '((((class color) (background dark)) - ()) + (:foreground "turquoise3")) (((class color) (background light)) - ()) + (:foreground "DeepSkyBlue4")) (t ())) "Level 3 empty newsgroup face." @@ -425,28 +397,21 @@ be set in `.emacs' instead." (put 'gnus-group-news-3-empty-face 'face-alias 'gnus-group-news-3-empty) (put 'gnus-group-news-3-empty-face 'obsolete-face "22.1") -(defface gnus-group-news-4 - '((((class color) - (background dark)) - (:bold t)) - (((class color) - (background light)) - (:bold t)) - (t - ())) - "Level 4 newsgroup face." +(defface gnus-group-news-3 + '((t (:inherit gnus-group-news-3-empty :bold t))) + "Level 3 newsgroup face." :group 'gnus-group) ;; backward-compatibility alias -(put 'gnus-group-news-4-face 'face-alias 'gnus-group-news-4) -(put 'gnus-group-news-4-face 'obsolete-face "22.1") +(put 'gnus-group-news-3-face 'face-alias 'gnus-group-news-3) +(put 'gnus-group-news-3-face 'obsolete-face "22.1") (defface gnus-group-news-4-empty '((((class color) (background dark)) - ()) + (:foreground "turquoise2")) (((class color) (background light)) - ()) + (:foreground "DeepSkyBlue3")) (t ())) "Level 4 empty newsgroup face." @@ -455,28 +420,21 @@ be set in `.emacs' instead." (put 'gnus-group-news-4-empty-face 'face-alias 'gnus-group-news-4-empty) (put 'gnus-group-news-4-empty-face 'obsolete-face "22.1") -(defface gnus-group-news-5 - '((((class color) - (background dark)) - (:bold t)) - (((class color) - (background light)) - (:bold t)) - (t - ())) - "Level 5 newsgroup face." +(defface gnus-group-news-4 + '((t (:inherit gnus-group-news-4-empty :bold t))) + "Level 4 newsgroup face." :group 'gnus-group) ;; backward-compatibility alias -(put 'gnus-group-news-5-face 'face-alias 'gnus-group-news-5) -(put 'gnus-group-news-5-face 'obsolete-face "22.1") +(put 'gnus-group-news-4-face 'face-alias 'gnus-group-news-4) +(put 'gnus-group-news-4-face 'obsolete-face "22.1") (defface gnus-group-news-5-empty '((((class color) (background dark)) - ()) + (:foreground "turquoise1")) (((class color) (background light)) - ()) + (:foreground "DeepSkyBlue2")) (t ())) "Level 5 empty newsgroup face." @@ -485,20 +443,13 @@ be set in `.emacs' instead." (put 'gnus-group-news-5-empty-face 'face-alias 'gnus-group-news-5-empty) (put 'gnus-group-news-5-empty-face 'obsolete-face "22.1") -(defface gnus-group-news-6 - '((((class color) - (background dark)) - (:bold t)) - (((class color) - (background light)) - (:bold t)) - (t - ())) - "Level 6 newsgroup face." +(defface gnus-group-news-5 + '((t (:inherit gnus-group-news-5-empty :bold t))) + "Level 5 newsgroup face." :group 'gnus-group) ;; backward-compatibility alias -(put 'gnus-group-news-6-face 'face-alias 'gnus-group-news-6) -(put 'gnus-group-news-6-face 'obsolete-face "22.1") +(put 'gnus-group-news-5-face 'face-alias 'gnus-group-news-5) +(put 'gnus-group-news-5-face 'obsolete-face "22.1") (defface gnus-group-news-6-empty '((((class color) @@ -515,20 +466,13 @@ be set in `.emacs' instead." (put 'gnus-group-news-6-empty-face 'face-alias 'gnus-group-news-6-empty) (put 'gnus-group-news-6-empty-face 'obsolete-face "22.1") -(defface gnus-group-news-low - '((((class color) - (background dark)) - (:foreground "DarkTurquoise" :bold t)) - (((class color) - (background light)) - (:foreground "DarkGreen" :bold t)) - (t - ())) - "Low level newsgroup face." +(defface gnus-group-news-6 + '((t (:inherit gnus-group-news-6-empty :bold t))) + "Level 6 newsgroup face." :group 'gnus-group) ;; backward-compatibility alias -(put 'gnus-group-news-low-face 'face-alias 'gnus-group-news-low) -(put 'gnus-group-news-low-face 'obsolete-face "22.1") +(put 'gnus-group-news-6-face 'face-alias 'gnus-group-news-6) +(put 'gnus-group-news-6-face 'obsolete-face "22.1") (defface gnus-group-news-low-empty '((((class color) @@ -545,20 +489,13 @@ be set in `.emacs' instead." (put 'gnus-group-news-low-empty-face 'face-alias 'gnus-group-news-low-empty) (put 'gnus-group-news-low-empty-face 'obsolete-face "22.1") -(defface gnus-group-mail-1 - '((((class color) - (background dark)) - (:foreground "#e1ffe1" :bold t)) - (((class color) - (background light)) - (:foreground "DeepPink3" :bold t)) - (t - (:bold t))) - "Level 1 mailgroup face." +(defface gnus-group-news-low + '((t (:inherit gnus-group-news-low-empty :bold t))) + "Low level newsgroup face." :group 'gnus-group) ;; backward-compatibility alias -(put 'gnus-group-mail-1-face 'face-alias 'gnus-group-mail-1) -(put 'gnus-group-mail-1-face 'obsolete-face "22.1") +(put 'gnus-group-news-low-face 'face-alias 'gnus-group-news-low) +(put 'gnus-group-news-low-face 'obsolete-face "22.1") (defface gnus-group-mail-1-empty '((((class color) @@ -568,27 +505,20 @@ be set in `.emacs' instead." (background light)) (:foreground "DeepPink3")) (t - (:italic t :bold t))) + (:italic t))) "Level 1 empty mailgroup face." :group 'gnus-group) ;; backward-compatibility alias (put 'gnus-group-mail-1-empty-face 'face-alias 'gnus-group-mail-1-empty) (put 'gnus-group-mail-1-empty-face 'obsolete-face "22.1") -(defface gnus-group-mail-2 - '((((class color) - (background dark)) - (:foreground "DarkSeaGreen1" :bold t)) - (((class color) - (background light)) - (:foreground "HotPink3" :bold t)) - (t - (:bold t))) - "Level 2 mailgroup face." +(defface gnus-group-mail-1 + '((t (:inherit gnus-group-mail-1-empty :bold t))) + "Level 1 mailgroup face." :group 'gnus-group) ;; backward-compatibility alias -(put 'gnus-group-mail-2-face 'face-alias 'gnus-group-mail-2) -(put 'gnus-group-mail-2-face 'obsolete-face "22.1") +(put 'gnus-group-mail-1-face 'face-alias 'gnus-group-mail-1) +(put 'gnus-group-mail-1-face 'obsolete-face "22.1") (defface gnus-group-mail-2-empty '((((class color) @@ -598,27 +528,20 @@ be set in `.emacs' instead." (background light)) (:foreground "HotPink3")) (t - (:bold t))) + (:italic t))) "Level 2 empty mailgroup face." :group 'gnus-group) ;; backward-compatibility alias (put 'gnus-group-mail-2-empty-face 'face-alias 'gnus-group-mail-2-empty) (put 'gnus-group-mail-2-empty-face 'obsolete-face "22.1") -(defface gnus-group-mail-3 - '((((class color) - (background dark)) - (:foreground "aquamarine1" :bold t)) - (((class color) - (background light)) - (:foreground "magenta4" :bold t)) - (t - (:bold t))) - "Level 3 mailgroup face." +(defface gnus-group-mail-2 + '((t (:inherit gnus-group-mail-2-empty :bold t))) + "Level 2 mailgroup face." :group 'gnus-group) ;; backward-compatibility alias -(put 'gnus-group-mail-3-face 'face-alias 'gnus-group-mail-3) -(put 'gnus-group-mail-3-face 'obsolete-face "22.1") +(put 'gnus-group-mail-2-face 'face-alias 'gnus-group-mail-2) +(put 'gnus-group-mail-2-face 'obsolete-face "22.1") (defface gnus-group-mail-3-empty '((((class color) @@ -635,20 +558,13 @@ be set in `.emacs' instead." (put 'gnus-group-mail-3-empty-face 'face-alias 'gnus-group-mail-3-empty) (put 'gnus-group-mail-3-empty-face 'obsolete-face "22.1") -(defface gnus-group-mail-low - '((((class color) - (background dark)) - (:foreground "aquamarine2" :bold t)) - (((class color) - (background light)) - (:foreground "DeepPink4" :bold t)) - (t - (:bold t))) - "Low level mailgroup face." +(defface gnus-group-mail-3 + '((t (:inherit gnus-group-mail-3-empty :bold t))) + "Level 3 mailgroup face." :group 'gnus-group) ;; backward-compatibility alias -(put 'gnus-group-mail-low-face 'face-alias 'gnus-group-mail-low) -(put 'gnus-group-mail-low-face 'obsolete-face "22.1") +(put 'gnus-group-mail-3-face 'face-alias 'gnus-group-mail-3) +(put 'gnus-group-mail-3-face 'obsolete-face "22.1") (defface gnus-group-mail-low-empty '((((class color) @@ -665,6 +581,14 @@ be set in `.emacs' instead." (put 'gnus-group-mail-low-empty-face 'face-alias 'gnus-group-mail-low-empty) (put 'gnus-group-mail-low-empty-face 'obsolete-face "22.1") +(defface gnus-group-mail-low + '((t (:inherit gnus-group-mail-low-empty :bold t))) + "Low level mailgroup face." + :group 'gnus-group) +;; backward-compatibility alias +(put 'gnus-group-mail-low-face 'face-alias 'gnus-group-mail-low) +(put 'gnus-group-mail-low-face 'obsolete-face "22.1") + ;; Summary mode faces. (defface gnus-summary-selected '((t (:underline t))) @@ -683,15 +607,23 @@ be set in `.emacs' instead." (put 'gnus-summary-cancelled-face 'face-alias 'gnus-summary-cancelled) (put 'gnus-summary-cancelled-face 'obsolete-face "22.1") -(defface gnus-summary-high-ticked +(defface gnus-summary-normal-ticked '((((class color) (background dark)) - (:foreground "pink" :bold t)) + (:foreground "pink")) (((class color) (background light)) - (:foreground "firebrick" :bold t)) + (:foreground "firebrick")) (t - (:bold t))) + ())) + "Face used for normal interest ticked articles." + :group 'gnus-summary) +;; backward-compatibility alias +(put 'gnus-summary-normal-ticked-face 'face-alias 'gnus-summary-normal-ticked) +(put 'gnus-summary-normal-ticked-face 'obsolete-face "22.1") + +(defface gnus-summary-high-ticked + '((t (:inherit gnus-summary-normal-ticked :bold t))) "Face used for high interest ticked articles." :group 'gnus-summary) ;; backward-compatibility alias @@ -699,44 +631,30 @@ be set in `.emacs' instead." (put 'gnus-summary-high-ticked-face 'obsolete-face "22.1") (defface gnus-summary-low-ticked - '((((class color) - (background dark)) - (:foreground "pink" :italic t)) - (((class color) - (background light)) - (:foreground "firebrick" :italic t)) - (t - (:italic t))) + '((t (:inherit gnus-summary-normal-ticked :italic t))) "Face used for low interest ticked articles." :group 'gnus-summary) ;; backward-compatibility alias (put 'gnus-summary-low-ticked-face 'face-alias 'gnus-summary-low-ticked) (put 'gnus-summary-low-ticked-face 'obsolete-face "22.1") -(defface gnus-summary-normal-ticked +(defface gnus-summary-normal-ancient '((((class color) (background dark)) - (:foreground "pink")) + (:foreground "SkyBlue")) (((class color) (background light)) - (:foreground "firebrick")) + (:foreground "RoyalBlue")) (t ())) - "Face used for normal interest ticked articles." + "Face used for normal interest ancient articles." :group 'gnus-summary) ;; backward-compatibility alias -(put 'gnus-summary-normal-ticked-face 'face-alias 'gnus-summary-normal-ticked) -(put 'gnus-summary-normal-ticked-face 'obsolete-face "22.1") +(put 'gnus-summary-normal-ancient-face 'face-alias 'gnus-summary-normal-ancient) +(put 'gnus-summary-normal-ancient-face 'obsolete-face "22.1") (defface gnus-summary-high-ancient - '((((class color) - (background dark)) - (:foreground "SkyBlue" :bold t)) - (((class color) - (background light)) - (:foreground "RoyalBlue" :bold t)) - (t - (:bold t))) + '((t (:inherit gnus-summary-normal-ancient :bold t))) "Face used for high interest ancient articles." :group 'gnus-summary) ;; backward-compatibility alias @@ -744,42 +662,28 @@ be set in `.emacs' instead." (put 'gnus-summary-high-ancient-face 'obsolete-face "22.1") (defface gnus-summary-low-ancient - '((((class color) - (background dark)) - (:foreground "SkyBlue" :italic t)) - (((class color) - (background light)) - (:foreground "RoyalBlue" :italic t)) - (t - (:italic t))) + '((t (:inherit gnus-summary-normal-ancient :italic t))) "Face used for low interest ancient articles." :group 'gnus-summary) ;; backward-compatibility alias (put 'gnus-summary-low-ancient-face 'face-alias 'gnus-summary-low-ancient) (put 'gnus-summary-low-ancient-face 'obsolete-face "22.1") -(defface gnus-summary-normal-ancient - '((((class color) - (background dark)) - (:foreground "SkyBlue")) - (((class color) - (background light)) - (:foreground "RoyalBlue")) - (t - ())) - "Face used for normal interest ancient articles." +(defface gnus-summary-normal-undownloaded + '((((class color) + (background light)) + (:foreground "cyan4" :bold nil)) + (((class color) (background dark)) + (:foreground "LightGray" :bold nil)) + (t (:inverse-video t))) + "Face used for normal interest uncached articles." :group 'gnus-summary) ;; backward-compatibility alias -(put 'gnus-summary-normal-ancient-face 'face-alias 'gnus-summary-normal-ancient) -(put 'gnus-summary-normal-ancient-face 'obsolete-face "22.1") +(put 'gnus-summary-normal-undownloaded-face 'face-alias 'gnus-summary-normal-undownloaded) +(put 'gnus-summary-normal-undownloaded-face 'obsolete-face "22.1") (defface gnus-summary-high-undownloaded - '((((class color) - (background light)) - (:bold t :foreground "cyan4")) - (((class color) (background dark)) - (:bold t :foreground "LightGray")) - (t (:inverse-video t :bold t))) + '((t (:inherit gnus-summary-normal-undownloaded :bold t))) "Face used for high interest uncached articles." :group 'gnus-summary) ;; backward-compatibility alias @@ -787,34 +691,24 @@ be set in `.emacs' instead." (put 'gnus-summary-high-undownloaded-face 'obsolete-face "22.1") (defface gnus-summary-low-undownloaded - '((((class color) - (background light)) - (:italic t :foreground "cyan4" :bold nil)) - (((class color) (background dark)) - (:italic t :foreground "LightGray" :bold nil)) - (t (:inverse-video t :italic t))) + '((t (:inherit gnus-summary-normal-undownloaded :italic t))) "Face used for low interest uncached articles." :group 'gnus-summary) ;; backward-compatibility alias (put 'gnus-summary-low-undownloaded-face 'face-alias 'gnus-summary-low-undownloaded) (put 'gnus-summary-low-undownloaded-face 'obsolete-face "22.1") -(defface gnus-summary-normal-undownloaded - '((((class color) - (background light)) - (:foreground "cyan4" :bold nil)) - (((class color) (background dark)) - (:foreground "LightGray" :bold nil)) - (t (:inverse-video t))) - "Face used for normal interest uncached articles." +(defface gnus-summary-normal-unread + '((t + ())) + "Face used for normal interest unread articles." :group 'gnus-summary) ;; backward-compatibility alias -(put 'gnus-summary-normal-undownloaded-face 'face-alias 'gnus-summary-normal-undownloaded) -(put 'gnus-summary-normal-undownloaded-face 'obsolete-face "22.1") +(put 'gnus-summary-normal-unread-face 'face-alias 'gnus-summary-normal-unread) +(put 'gnus-summary-normal-unread-face 'obsolete-face "22.1") (defface gnus-summary-high-unread - '((t - (:bold t))) + '((t (:inherit gnus-summary-normal-unread :bold t))) "Face used for high interest unread articles." :group 'gnus-summary) ;; backward-compatibility alias @@ -822,34 +716,30 @@ be set in `.emacs' instead." (put 'gnus-summary-high-unread-face 'obsolete-face "22.1") (defface gnus-summary-low-unread - '((t - (:italic t))) + '((t (:inherit gnus-summary-normal-unread :italic t))) "Face used for low interest unread articles." :group 'gnus-summary) ;; backward-compatibility alias (put 'gnus-summary-low-unread-face 'face-alias 'gnus-summary-low-unread) (put 'gnus-summary-low-unread-face 'obsolete-face "22.1") -(defface gnus-summary-normal-unread - '((t - ())) - "Face used for normal interest unread articles." - :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-normal-unread-face 'face-alias 'gnus-summary-normal-unread) -(put 'gnus-summary-normal-unread-face 'obsolete-face "22.1") - -(defface gnus-summary-high-read +(defface gnus-summary-normal-read '((((class color) (background dark)) - (:foreground "PaleGreen" - :bold t)) + (:foreground "PaleGreen")) (((class color) (background light)) - (:foreground "DarkGreen" - :bold t)) + (:foreground "DarkGreen")) (t - (:bold t))) + ())) + "Face used for normal interest read articles." + :group 'gnus-summary) +;; backward-compatibility alias +(put 'gnus-summary-normal-read-face 'face-alias 'gnus-summary-normal-read) +(put 'gnus-summary-normal-read-face 'obsolete-face "22.1") + +(defface gnus-summary-high-read + '((t (:inherit gnus-summary-normal-read :bold t))) "Face used for high interest read articles." :group 'gnus-summary) ;; backward-compatibility alias @@ -857,37 +747,13 @@ be set in `.emacs' instead." (put 'gnus-summary-high-read-face 'obsolete-face "22.1") (defface gnus-summary-low-read - '((((class color) - (background dark)) - (:foreground "PaleGreen" - :italic t)) - (((class color) - (background light)) - (:foreground "DarkGreen" - :italic t)) - (t - (:italic t))) + '((t (:inherit gnus-summary-normal-read :italic t))) "Face used for low interest read articles." :group 'gnus-summary) ;; backward-compatibility alias (put 'gnus-summary-low-read-face 'face-alias 'gnus-summary-low-read) (put 'gnus-summary-low-read-face 'obsolete-face "22.1") -(defface gnus-summary-normal-read - '((((class color) - (background dark)) - (:foreground "PaleGreen")) - (((class color) - (background light)) - (:foreground "DarkGreen")) - (t - ())) - "Face used for normal interest read articles." - :group 'gnus-summary) -;; backward-compatibility alias -(put 'gnus-summary-normal-read-face 'face-alias 'gnus-summary-normal-read) -(put 'gnus-summary-normal-read-face 'obsolete-face "22.1") - ;;; ;;; Gnus buffers @@ -1106,12 +972,11 @@ be set in `.emacs' instead." (cons (car list) (list :type type :data data))) list))) -(eval-when (load) - (let ((command (format "%s" this-command))) - (when (string-match "gnus" command) - (if (string-match "gnus-other-frame" command) - (gnus-get-buffer-create gnus-group-buffer) - (gnus-splash))))) +(let ((command (format "%s" this-command))) + (when (string-match "gnus" command) + (if (eq 'gnus-other-frame this-command) + (gnus-get-buffer-create gnus-group-buffer) + (gnus-splash)))) ;;; Do the rest. @@ -2479,7 +2344,7 @@ Disabling the agent may result in noticeable loss of performance." :group 'gnus-agent :type 'boolean) -(defcustom gnus-other-frame-function 'gnus +(defcustom gnus-other-frame-function #'gnus "Function called by the command `gnus-other-frame' when starting Gnus." :group 'gnus-start :type '(choice (function-item gnus) @@ -2487,7 +2352,9 @@ Disabling the agent may result in noticeable loss of performance." (function-item gnus-slave) (function-item gnus-slave-no-server))) -(defcustom gnus-other-frame-resume-function 'gnus-group-get-new-news +(declare-function gnus-group-get-new-news "gnus-group") + +(defcustom gnus-other-frame-resume-function #'gnus-group-get-new-news "Function called by the command `gnus-other-frame' when resuming Gnus." :version "24.4" :group 'gnus-start @@ -2555,7 +2422,7 @@ a string, be sure to use a valid format, see RFC 2616." ) (defvar gnus-agent-target-move-group-header "X-Gnus-Agent-Move-To") (defvar gnus-draft-meta-information-header "X-Draft-From") -(defvar gnus-group-get-parameter-function 'gnus-group-get-parameter) +(defvar gnus-group-get-parameter-function #'gnus-group-get-parameter) (defvar gnus-original-article-buffer " *Original Article*") (defvar gnus-newsgroup-name nil) (defvar gnus-ephemeral-servers nil) @@ -2592,7 +2459,9 @@ a string, be sure to use a valid format, see RFC 2616." (defvar gnus-group-history nil) (defvar gnus-server-alist nil - "List of available servers.") + "Servers created by Gnus, or via the server buffer. +Servers defined in the user's config files do not appear here. +This variable is persisted in the user's .newsrc.eld file.") (defcustom gnus-cache-directory (nnheader-concat gnus-directory "cache/") @@ -2755,7 +2624,6 @@ gnus-registry.el will populate this if it's loaded.") (nthcdr 3 package) (cdr package))))) '(("info" :interactive t Info-goto-node) - ("pp" pp-to-string) ("qp" quoted-printable-decode-region quoted-printable-decode-string) ("ps-print" ps-print-preprint) ("message" :interactive t @@ -2902,7 +2770,6 @@ gnus-registry.el will populate this if it's loaded.") gnus-check-reasonable-setup) ("gnus-dup" gnus-dup-suppress-articles gnus-dup-unsuppress-article gnus-dup-enter-articles) - ("gnus-range" gnus-copy-sequence) ("gnus-eform" gnus-edit-form) ("gnus-logic" gnus-score-advanced) ("gnus-undo" gnus-undo-mode gnus-undo-register) @@ -3179,9 +3046,9 @@ with a `subscribed' parameter." (or (gnus-group-fast-parameter group 'to-address) (gnus-group-fast-parameter group 'to-list)))) (when address - (add-to-list 'addresses address)))) + (cl-pushnew address addresses :test #'equal)))) (when addresses - (list (mapconcat 'regexp-quote addresses "\\|"))))) + (list (mapconcat #'regexp-quote addresses "\\|"))))) (defmacro gnus-string-or (&rest strings) "Return the first element of STRINGS that is a non-blank string. @@ -3234,6 +3101,8 @@ If ARG, insert string at point." minor least) (format "%d.%02d%02d" major minor least)))))) +(defvar gnus-info-buffer) + (defun gnus-info-find-node (&optional nodename) "Find Info documentation of Gnus." (interactive) @@ -3253,7 +3122,7 @@ If ARG, insert string at point." (defvar gnus-current-prefix-symbols nil "List of current prefix symbols.") -(defun gnus-interactive (string &optional params) +(defun gnus-interactive (string) "Return a list that can be fed to `interactive'. See `interactive' for full documentation. @@ -3345,9 +3214,9 @@ g -- Group name." (setq out (delq 'gnus-prefix-nil out)) (nreverse out))) -(defun gnus-symbolic-argument (&optional arg) +(defun gnus-symbolic-argument () "Read a symbolic argument and a command, and then execute command." - (interactive "P") + (interactive) (let* ((in-command (this-command-keys)) (command in-command) gnus-current-prefix-symbols @@ -3463,16 +3332,15 @@ that that variable is buffer-local to the summary buffers." (throw 'server-name (car name-method)))) gnus-server-method-cache)) - (mapc - (lambda (server-alist) - (mapc (lambda (name-method) - (when (gnus-methods-equal-p (cdr name-method) method) - (unless (member name-method gnus-server-method-cache) - (push name-method gnus-server-method-cache)) - (throw 'server-name (car name-method)))) - server-alist)) - (list gnus-server-alist - gnus-predefined-server-alist)) + (dolist (server-alist + (list gnus-server-alist + gnus-predefined-server-alist)) + (mapc (lambda (name-method) + (when (gnus-methods-equal-p (cdr name-method) method) + (unless (member name-method gnus-server-method-cache) + (push name-method gnus-server-method-cache)) + (throw 'server-name (car name-method)))) + server-alist)) (let* ((name (if (member (cadr method) '(nil "")) (format "%s" (car method)) @@ -3574,26 +3442,26 @@ that that variable is buffer-local to the summary buffers." (let ((p1 (copy-sequence (cddr m1))) (p2 (copy-sequence (cddr m2))) e1 e2) - (block nil + (cl-block nil (while (setq e1 (pop p1)) (unless (setq e2 (assq (car e1) p2)) ;; The parameter doesn't exist in p2. - (return nil)) + (cl-return nil)) (setq p2 (delq e2 p2)) (unless (equal e1 e2) (if (not (and (stringp (cadr e1)) (stringp (cadr e2)))) - (return nil) + (cl-return nil) ;; Special-case string parameter comparison so that we ;; can uniquify them. (let ((s1 (cadr e1)) (s2 (cadr e2))) - (when (string-match "/$" s1) + (when (string-match "/\\'" s1) (setq s1 (directory-file-name s1))) - (when (string-match "/$" s2) + (when (string-match "/\\'" s2) (setq s2 (directory-file-name s2))) (unless (equal s1 s2) - (return nil)))))) + (cl-return nil)))))) ;; If p2 now is empty, they were equal. (null p2)))) @@ -3981,8 +3849,7 @@ If SCORE is nil, add 1 to the score of GROUP." "Collapse GROUP name LEVELS. Select methods are stripped and any remote host name is stripped down to just the host name." - (let* ((name "") - (foreign "") + (let* ((foreign "") (depth 0) (skip 1) (levels (or levels @@ -4024,13 +3891,13 @@ just the host name." gsep ".")) (setq levels (- glen levels)) (dolist (g glist) - (push (if (>= (decf levels) 0) + (push (if (>= (cl-decf levels) 0) (if (zerop (length g)) "" (substring g 0 1)) g) res)) - (concat foreign (mapconcat 'identity (nreverse res) gsep)))))) + (concat foreign (mapconcat #'identity (nreverse res) gsep)))))) (defun gnus-narrow-to-body () "Narrow to the body of an article." @@ -4272,7 +4139,7 @@ Allow completion over sensible values." gnus-server-alist)) (method (gnus-completing-read - prompt (mapcar 'car servers) + prompt (mapcar #'car servers) t nil 'gnus-method-history))) (cond ((equal method "") @@ -4385,13 +4252,13 @@ current display is used." (progn (switch-to-buffer gnus-group-buffer) (funcall gnus-other-frame-resume-function arg)) (funcall gnus-other-frame-function arg) - (add-hook 'gnus-exit-gnus-hook 'gnus-delete-gnus-frame) + (add-hook 'gnus-exit-gnus-hook #'gnus-delete-gnus-frame) ;; One might argue that `gnus-delete-gnus-frame' should not be called ;; from `gnus-suspend-gnus-hook', but, on the other hand, one might ;; argue that it should. No matter what you think, for the sake of ;; those who want it to be called from it, please keep (defun ;; gnus-delete-gnus-frame) even if you remove the next `add-hook'. - (add-hook 'gnus-suspend-gnus-hook 'gnus-delete-gnus-frame))))) + (add-hook 'gnus-suspend-gnus-hook #'gnus-delete-gnus-frame))))) ;;;###autoload (defun gnus (&optional arg dont-connect slave) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index aa6178be705..37197287ac0 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -28,8 +28,7 @@ ;;; Code: -(eval-when-compile - (require 'cl)) +(eval-when-compile (require 'cl-lib)) (require 'mailheader) (require 'gmm-utils) @@ -2434,7 +2433,7 @@ Return the number of headers removed." (not (looking-at regexp)) (looking-at regexp)) (progn - (incf number) + (cl-incf number) (when first (setq last t)) (delete-region @@ -2459,10 +2458,10 @@ Return the number of headers removed." (save-excursion (goto-char (point-min)) (while (re-search-forward regexp nil t) - (incf count))) + (cl-incf count))) (while (> count 1) (message-remove-header header nil t) - (decf count)))) + (cl-decf count)))) (defun message-narrow-to-headers () "Narrow the buffer to the head of the message." @@ -3217,13 +3216,13 @@ or in the synonym headers, defined by `message-header-synonyms'." (dolist (header headers) (let* ((header-name (symbol-name (car header))) (new-header (cdr header)) - (synonyms (loop for synonym in message-header-synonyms - when (memq (car header) synonym) return synonym)) + (synonyms (cl-loop for synonym in message-header-synonyms + when (memq (car header) synonym) return synonym)) (old-header - (loop for synonym in synonyms - for old-header = (mail-fetch-field (symbol-name synonym)) - when (and old-header (string-match new-header old-header)) - return synonym))) + (cl-loop for synonym in synonyms + for old-header = (mail-fetch-field (symbol-name synonym)) + when (and old-header (string-match new-header old-header)) + return synonym))) (if old-header (message "already have `%s' in `%s'" new-header old-header) (when (and (message-position-on-field header-name) @@ -3583,7 +3582,7 @@ text was killed." "Create a rot table with offset N." (let ((i -1) (table (make-string 256 0))) - (while (< (incf i) 256) + (while (< (cl-incf i) 256) (aset table i i)) (concat (substring table 0 ?A) @@ -3751,13 +3750,13 @@ To use this automatically, you may add this function to (goto-char (mark t)) (insert-before-markers ?\n) (goto-char pt)))) - (case message-cite-reply-position - (above + (pcase message-cite-reply-position + ('above (message-goto-body) (insert body-text) (insert (if (bolp) "\n" "\n\n")) (message-goto-body)) - (below + ('below (message-goto-signature))) ;; Add a `message-setup-very-last-hook' here? ;; Add `gnus-article-highlight-citation' here? @@ -4380,7 +4379,7 @@ This function could be useful in `message-setup-hook'." (if (string= encoded bog) "" (format " (%s)" encoded)))))) - (error "Bogus address")))))))) + (user-error "Bogus address")))))))) (custom-add-option 'message-setup-hook 'message-check-recipients) @@ -4602,9 +4601,9 @@ This function could be useful in `message-setup-hook'." (with-current-buffer mailbuf message-courtesy-message))) ;; Let's make sure we encoded all the body. - (assert (save-excursion - (goto-char (point-min)) - (not (re-search-forward "[^\000-\377]" nil t)))) + (cl-assert (save-excursion + (goto-char (point-min)) + (not (re-search-forward "[^\000-\377]" nil t)))) (mm-disable-multibyte) (if (or (not message-send-mail-partially-limit) (< (buffer-size) message-send-mail-partially-limit) @@ -4758,7 +4757,7 @@ to find out how to use this." (replace-match "\n") (run-hooks 'message-send-mail-hook) ;; send the message - (case + (pcase (let ((coding-system-for-write message-send-coding-system)) (apply 'call-process-region (point-min) (point-max) @@ -4789,7 +4788,7 @@ to find out how to use this." (100 (error "qmail-inject reported permanent failure")) (111 (error "qmail-inject reported transient failure")) ;; should never happen - (t (error "qmail-inject reported unknown failure")))) + (_ (error "qmail-inject reported unknown failure")))) (defvar mh-previous-window-config) @@ -5312,7 +5311,9 @@ Otherwise, generate and save a value for `canlock-password' first." ;; Check for control characters. (message-check 'control-chars (if (re-search-forward - (string-to-multibyte "[\000-\007\013\015-\032\034-\037\200-\237]") + (eval-when-compile + (decode-coding-string "[\000-\007\013\015-\032\034-\037\200-\237]" + 'binary)) nil t) (y-or-n-p "The article contains control characters. Really post? ") @@ -5839,10 +5840,10 @@ subscribed address (and not the additional To and Cc header contents)." message-subscribed-address-functions)))) (save-match-data (let ((list - (loop for recipient in recipients - when (loop for regexp in mft-regexps - thereis (string-match regexp recipient)) - return recipient))) + (cl-loop for recipient in recipients + when (cl-loop for regexp in mft-regexps + thereis (string-match regexp recipient)) + return recipient))) (when list (if only-show-subscribed list @@ -6191,7 +6192,7 @@ they are." (when (> count maxcount) (let ((surplus (- count maxcount))) (message-shorten-1 refs cut surplus) - (decf count surplus))) + (cl-decf count surplus))) ;; When sending via news, make sure the total folded length will ;; be less than 998 characters. This is to cater to broken INN @@ -6716,9 +6717,9 @@ The function is called with one parameter, a cons cell ..." ;; Gmane renames "To". Look at "Original-To", too, if it is present in ;; message-header-synonyms. (setq to (or (message-fetch-field "to") - (and (loop for synonym in message-header-synonyms - when (memq 'Original-To synonym) - return t) + (and (cl-loop for synonym in message-header-synonyms + when (memq 'Original-To synonym) + return t) (message-fetch-field "original-to"))) cc (message-fetch-field "cc") extra (when message-extra-wide-headers @@ -8123,11 +8124,12 @@ From headers in the original article." (message-tokenize-header (mail-strip-quoted-names (mapconcat 'message-fetch-reply-field fields ",")))) - (email (cond ((functionp message-alternative-emails) - (car (cl-remove-if-not message-alternative-emails emails))) - (t (loop for email in emails - if (string-match-p message-alternative-emails email) - return email))))) + (email + (cond ((functionp message-alternative-emails) + (car (cl-remove-if-not message-alternative-emails emails))) + (t (cl-loop for email in emails + if (string-match-p message-alternative-emails email) + return email))))) (unless (or (not email) (equal email user-mail-address)) (message-remove-header "From") (goto-char (point-max)) diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el index 2d3d3d16a84..04bb3b56530 100644 --- a/lisp/gnus/nndiary.el +++ b/lisp/gnus/nndiary.el @@ -1532,7 +1532,7 @@ all. This may very well take some time.") ;; past. A permanent schedule never expires. (and sched (setq sched (nndiary-last-occurrence sched)) - (time-less-p sched (current-time)))) + (time-less-p sched nil))) ;; else (nnheader-report 'nndiary "Could not read file %s" file) nil) diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el index 88156d1af82..1462578ec20 100644 --- a/lisp/gnus/nnmail.el +++ b/lisp/gnus/nnmail.el @@ -1883,7 +1883,7 @@ If TIME is nil, then return the cutoff time for oldness instead." (setq days (days-to-time days)) ;; Compare the time with the current time. (if (null time) - (time-subtract (current-time) days) + (time-subtract nil days) (ignore-errors (time-less-p days (time-since time))))))))) (declare-function gnus-group-mark-article-read "gnus-group" (group article)) @@ -2034,7 +2034,7 @@ If TIME is nil, then return the cutoff time for oldness instead." "Remove all instances of GROUP from `nnmail-split-history'." (let ((history nnmail-split-history)) (while history - (setcar history (gnus-remove-if (lambda (e) (string= (car e) group)) + (setcar history (seq-remove (lambda (e) (string= (car e) group)) (car history))) (pop history)) (setq nnmail-split-history (delq nil nnmail-split-history)))) diff --git a/lisp/gnus/nnmaildir.el b/lisp/gnus/nnmaildir.el index 272240f5a9f..3e4a87cee77 100644 --- a/lisp/gnus/nnmaildir.el +++ b/lisp/gnus/nnmaildir.el @@ -814,7 +814,7 @@ This variable is set by `nnmaildir-request-article'.") (when (or isnew nattr) (dolist (file (funcall ls ndir nil "\\`[^.]" 'nosort)) (setq x (concat ndir file)) - (and (time-less-p (nth 5 (file-attributes x)) (current-time)) + (and (time-less-p (nth 5 (file-attributes x)) nil) (rename-file x (concat cdir (nnmaildir--ensure-suffix file))))) (setf (nnmaildir--grp-new group) nattr)) (setq cattr (nth 5 (file-attributes cdir))) @@ -915,7 +915,7 @@ This variable is set by `nnmaildir-request-article'.") (setq dirs (funcall srv-ls srv-dir nil "\\`[^.]" 'nosort) dirs (if (zerop (length target-prefix)) dirs - (gnus-remove-if + (seq-remove (lambda (dir) (and (>= (length dir) (length target-prefix)) (string= (substring dir 0 diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el index 3ab7d0893b9..a04ede67844 100644 --- a/lisp/gnus/nnrss.el +++ b/lisp/gnus/nnrss.el @@ -625,7 +625,7 @@ which RSS 2.0 allows." ;;; Snarf functions (defun nnrss-make-hash-index (item) (gnus-message 9 "nnrss: Making hash index of %s" (gnus-prin1-to-string item)) - (setq item (gnus-remove-if + (setq item (seq-remove (lambda (field) (when (listp field) (memq (car field) nnrss-ignore-article-fields))) diff --git a/lisp/gnus/score-mode.el b/lisp/gnus/score-mode.el index 9ef0598ee09..0ac56a9a3d9 100644 --- a/lisp/gnus/score-mode.el +++ b/lisp/gnus/score-mode.el @@ -85,7 +85,7 @@ This mode is an extended emacs-lisp mode. (defun gnus-score-edit-insert-date () "Insert date in numerical format." (interactive) - (princ (time-to-days (current-time)) (current-buffer))) + (princ (time-to-days nil) (current-buffer))) (defun gnus-score-pretty-print () "Format the current score file." diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 9ffb7ff59cd..7a94d2f61ae 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -721,6 +721,10 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." ((invalid-function void-function) doc-raw)))) (run-hook-with-args 'help-fns-describe-function-functions function) (insert "\n" (or doc "Not documented."))) + (when (or (function-get function 'pure) + (function-get function 'side-effect-free)) + (insert "\nThis function does not change global state, " + "including the match data.")) ;; Avoid asking the user annoying questions if she decides ;; to save the help buffer, when her locale's codeset ;; isn't UTF-8. diff --git a/lisp/help-mode.el b/lisp/help-mode.el index 68fc319e68c..ee481cf43f6 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -203,12 +203,18 @@ The format is (FUNCTION ARGS...).") (help-C-file-name (indirect-function fun) 'fun))) ;; Don't use find-function-noselect because it follows ;; aliases (which fails for built-in functions). - (let ((location - (find-function-search-for-symbol fun type file))) + (let* ((location + (find-function-search-for-symbol fun type file)) + (position (cdr location))) (pop-to-buffer (car location)) (run-hooks 'find-function-after-hook) - (if (cdr location) - (goto-char (cdr location)) + (if position + (progn + ;; Widen the buffer if necessary to go to this position. + (when (or (< position (point-min)) + (> position (point-max))) + (widen)) + (goto-char position)) (message "Unable to find location in file"))))) 'help-echo (purecopy "mouse-2, RET: find function's definition")) @@ -219,6 +225,7 @@ The format is (FUNCTION ARGS...).") (if (and file (file-readable-p file)) (progn (pop-to-buffer (find-file-noselect file)) + (widen) (goto-char (point-min)) (if (re-search-forward (format "^[ \t]*(\\(cl-\\)?define-compiler-macro[ \t]+%s" @@ -234,12 +241,18 @@ The format is (FUNCTION ARGS...).") 'help-function (lambda (var &optional file) (when (eq file 'C-source) (setq file (help-C-file-name var 'var))) - (let ((location (find-variable-noselect var file))) + (let* ((location (find-variable-noselect var file)) + (position (cdr location))) (pop-to-buffer (car location)) (run-hooks 'find-function-after-hook) - (if (cdr location) - (goto-char (cdr location)) - (message "Unable to find location in file")))) + (if position + (progn + ;; Widen the buffer if necessary to go to this position. + (when (or (< position (point-min)) + (> position (point-max))) + (widen)) + (goto-char position)) + (message "Unable to find location in file")))) 'help-echo (purecopy "mouse-2, RET: find variable's definition")) (define-button-type 'help-face-def @@ -248,12 +261,18 @@ The format is (FUNCTION ARGS...).") (require 'find-func) ;; Don't use find-function-noselect because it follows ;; aliases (which fails for built-in functions). - (let ((location - (find-function-search-for-symbol fun 'defface file))) + (let* ((location + (find-function-search-for-symbol fun 'defface file)) + (position (cdr location))) (pop-to-buffer (car location)) - (if (cdr location) - (goto-char (cdr location)) - (message "Unable to find location in file")))) + (if position + (progn + ;; Widen the buffer if necessary to go to this position. + (when (or (< position (point-min)) + (> position (point-max))) + (widen)) + (goto-char position)) + (message "Unable to find location in file")))) 'help-echo (purecopy "mouse-2, RET: find face's definition")) (define-button-type 'help-package diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el index 2023165b2a6..91d9acb3a3c 100644 --- a/lisp/ibuf-ext.el +++ b/lisp/ibuf-ext.el @@ -1033,8 +1033,11 @@ group definitions by setting `ibuffer-filter-groups' to nil." (ibuffer-jump-to-buffer (buffer-name buf))))) (defun ibuffer-push-filter (filter-specification) - "Add FILTER-SPECIFICATION to `ibuffer-filtering-qualifiers'." - (push filter-specification ibuffer-filtering-qualifiers)) + "Add FILTER-SPECIFICATION to `ibuffer-filtering-qualifiers'. +If FILTER-SPECIFICATION is already in the list then return nil. Otherwise, +return the updated list." + (unless (member filter-specification ibuffer-filtering-qualifiers) + (push filter-specification ibuffer-filtering-qualifiers))) ;;;###autoload (defun ibuffer-decompose-filter () @@ -1283,6 +1286,12 @@ currently used by buffers." :reader (read-from-minibuffer "Filter by name (regexp): ")) (string-match qualifier (buffer-name buf))) +;;;###autoload (autoload 'ibuffer-filter-by-process "ibuf-ext") +(define-ibuffer-filter process + "Limit current view to buffers running a process." + (:description "process") + (get-buffer-process buf)) + ;;;###autoload (autoload 'ibuffer-filter-by-starred-name "ibuf-ext") (define-ibuffer-filter starred-name "Limit current view to buffers with name beginning and ending diff --git a/lisp/ibuf-macs.el b/lisp/ibuf-macs.el index 6f7b492b821..6a70a8341a2 100644 --- a/lisp/ibuf-macs.el +++ b/lisp/ibuf-macs.el @@ -301,12 +301,16 @@ bound to the current value of the filter. (defun ,fn-name (qualifier) ,(or documentation "This filter is not documented.") (interactive (list ,reader)) - (ibuffer-push-filter (cons ',name qualifier)) - (message "%s" - (format ,(concat (format "Filter by %s added: " description) - " %s") - qualifier)) - (ibuffer-update nil t)) + (if (null (ibuffer-push-filter (cons ',name qualifier))) + (message "%s" + (format ,(concat (format "Filter by %s already applied: " description) + " %s") + qualifier)) + (message "%s" + (format ,(concat (format "Filter by %s added: " description) + " %s") + qualifier)) + (ibuffer-update nil t))) (push (list ',name ,description (lambda (buf qualifier) (condition-case nil diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el index 0a7bfe00a98..38fffcb976b 100644 --- a/lisp/ibuffer.el +++ b/lisp/ibuffer.el @@ -522,6 +522,7 @@ directory, like `default-directory'." (define-key map (kbd "/ m") 'ibuffer-filter-by-used-mode) (define-key map (kbd "/ M") 'ibuffer-filter-by-derived-mode) (define-key map (kbd "/ n") 'ibuffer-filter-by-name) + (define-key map (kbd "/ E") 'ibuffer-filter-by-process) (define-key map (kbd "/ *") 'ibuffer-filter-by-starred-name) (define-key map (kbd "/ f") 'ibuffer-filter-by-filename) (define-key map (kbd "/ b") 'ibuffer-filter-by-basename) diff --git a/lisp/image.el b/lisp/image.el index 0fe03f55bbb..2a8ea1fb886 100644 --- a/lisp/image.el +++ b/lisp/image.el @@ -976,11 +976,12 @@ default is 20%." image)) (defun image--get-imagemagick-and-warn () - (unless (fboundp 'imagemagick-types) + (unless (or (fboundp 'imagemagick-types) (featurep 'ns)) (error "Can't rescale images without ImageMagick support")) (let ((image (image--get-image))) (image-flush image) - (plist-put (cdr image) :type 'imagemagick) + (when (fboundp 'imagemagick-types) + (plist-put (cdr image) :type 'imagemagick)) image)) (defun image--change-size (factor) diff --git a/lisp/image/gravatar.el b/lisp/image/gravatar.el index e611e965abb..fe44f0dc834 100644 --- a/lisp/image/gravatar.el +++ b/lisp/image/gravatar.el @@ -77,11 +77,7 @@ (not (file-exists-p (url-cache-create-filename url)))) (t (let ((cache-time (url-is-cached url))) (if cache-time - (time-less-p - (time-add - cache-time - gravatar-cache-ttl) - (current-time)) + (time-less-p (time-add cache-time gravatar-cache-ttl) nil) t))))) (defun gravatar-get-data () diff --git a/lisp/info-look.el b/lisp/info-look.el index 858e246ad2e..dec16cf44cd 100644 --- a/lisp/info-look.el +++ b/lisp/info-look.el @@ -619,7 +619,8 @@ Return nil if there is nothing appropriate in the buffer near point." beg end) (cond ((and (memq (get-char-property (point) 'face) - '(custom-variable-tag custom-variable-tag-face)) + '(custom-variable-tag custom-variable-obsolete + custom-variable-tag-face)) (setq beg (previous-single-char-property-change (point) 'face nil (line-beginning-position))) (setq end (next-single-char-property-change diff --git a/lisp/kmacro.el b/lisp/kmacro.el index 8855fa5c314..76d2125c9d8 100644 --- a/lisp/kmacro.el +++ b/lisp/kmacro.el @@ -124,13 +124,11 @@ (defcustom kmacro-call-mouse-event 'S-mouse-3 "The mouse event used by kmacro to call a macro. Set to nil if no mouse binding is desired." - :type 'symbol - :group 'kmacro) + :type 'symbol) (defcustom kmacro-ring-max 8 "Maximum number of keyboard macros to save in macro ring." - :type 'integer - :group 'kmacro) + :type 'integer) (defcustom kmacro-execute-before-append t @@ -141,32 +139,27 @@ execute the macro. Otherwise, a single \\[universal-argument] prefix does not execute the macro, while more than one \\[universal-argument] prefix causes the macro to be executed before appending to it." - :type 'boolean - :group 'kmacro) + :type 'boolean) (defcustom kmacro-repeat-no-prefix t "Allow repeating certain macro commands without entering the C-x C-k prefix." - :type 'boolean - :group 'kmacro) + :type 'boolean) (defcustom kmacro-call-repeat-key t "Allow repeating macro call using last key or a specific key." :type '(choice (const :tag "Disabled" nil) (const :tag "Last key" t) (character :tag "Character" :value ?e) - (symbol :tag "Key symbol" :value RET)) - :group 'kmacro) + (symbol :tag "Key symbol" :value RET))) (defcustom kmacro-call-repeat-with-arg nil "Repeat macro call with original arg when non-nil; repeat once if nil." - :type 'boolean - :group 'kmacro) + :type 'boolean) (defcustom kmacro-step-edit-mini-window-height 0.75 "Override `max-mini-window-height' when step edit keyboard macro." - :type 'number - :group 'kmacro) + :type 'number) ;; Keymap @@ -261,7 +254,7 @@ previous `kmacro-counter', and do not modify counter." (if kmacro-initial-counter-value (setq kmacro-counter kmacro-initial-counter-value kmacro-initial-counter-value nil)) - (if (and arg (listp arg)) + (if (consp arg) (insert (format kmacro-counter-format kmacro-last-counter)) (insert (format kmacro-counter-format kmacro-counter)) (kmacro-add-counter (prefix-numeric-value arg)))) @@ -280,8 +273,8 @@ previous `kmacro-counter', and do not modify counter." (defun kmacro-display-counter (&optional value) "Display current counter value." (unless value (setq value kmacro-counter)) - (message "New macro counter value: %s (%d)" (format kmacro-counter-format value) value)) - + (message "New macro counter value: %s (%d)" + (format kmacro-counter-format value) value)) (defun kmacro-set-counter (arg) "Set `kmacro-counter' to ARG or prompt if missing. @@ -780,19 +773,18 @@ If kbd macro currently being defined end it before activating it." (defun kmacro-extract-lambda (mac) "Extract kmacro from a kmacro lambda form." - (and (consp mac) - (eq (car mac) 'lambda) + (and (eq (car-safe mac) 'lambda) (setq mac (assoc 'kmacro-exec-ring-item mac)) - (consp (cdr mac)) - (consp (car (cdr mac))) - (consp (cdr (car (cdr mac)))) - (setq mac (car (cdr (car (cdr mac))))) + (setq mac (car-safe (cdr-safe (car-safe (cdr-safe mac))))) (listp mac) (= (length mac) 3) (arrayp (car mac)) mac)) +(defalias 'kmacro-p #'kmacro-extract-lambda + "Return non-nil if MAC is a kmacro keyboard macro.") + (defun kmacro-bind-to-key (_arg) "When not defining or executing a macro, offer to bind last macro to a key. The key sequences [C-x C-k 0] through [C-x C-k 9] and [C-x C-k A] @@ -833,6 +825,13 @@ The ARG parameter is unused." (kmacro-lambda-form (kmacro-ring-head))) (message "Keyboard macro bound to %s" (format-kbd-macro key-seq)))))) +(defun kmacro-keyboard-macro-p (symbol) + "Return non-nil if SYMBOL is the name of some sort of keyboard macro." + (let ((f (symbol-function symbol))) + (when f + (or (stringp f) + (vectorp f) + (kmacro-p f))))) (defun kmacro-name-last-macro (symbol) "Assign a name to the last keyboard macro defined. @@ -843,14 +842,18 @@ Such a \"function\" cannot be called from Lisp, but it is a valid editor command (or last-kbd-macro (error "No keyboard macro defined")) (and (fboundp symbol) - (not (get symbol 'kmacro)) - (not (stringp (symbol-function symbol))) - (not (vectorp (symbol-function symbol))) + (not (kmacro-keyboard-macro-p symbol)) (error "Function %s is already defined and not a keyboard macro" symbol)) (if (string-equal symbol "") (error "No command name given")) + ;; FIXME: Use plain old `last-kbd-macro' for kmacros where it doesn't + ;; make a difference? (fset symbol (kmacro-lambda-form (kmacro-ring-head))) + ;; This used to be used to detect when a symbol corresponds to a kmacro. + ;; Nowadays it's unused because we used `kmacro-p' instead to see if the + ;; symbol's function definition matches that of a kmacro, which is more + ;; reliable. (put symbol 'kmacro t)) @@ -1209,7 +1212,7 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', (setq kmacro-step-edit-key-index next-index))) (defun kmacro-step-edit-pre-command () - (remove-hook 'post-command-hook 'kmacro-step-edit-post-command) + (remove-hook 'post-command-hook #'kmacro-step-edit-post-command) (when kmacro-step-edit-active (cond ((eq kmacro-step-edit-active 'ignore) @@ -1229,17 +1232,17 @@ following additional answers: `insert', `insert-1', `replace', `replace-1', (setq kmacro-step-edit-appending nil kmacro-step-edit-active 'ignore))))) (when (eq kmacro-step-edit-active t) - (add-hook 'post-command-hook 'kmacro-step-edit-post-command t))) + (add-hook 'post-command-hook #'kmacro-step-edit-post-command t))) (defun kmacro-step-edit-minibuf-setup () - (remove-hook 'pre-command-hook 'kmacro-step-edit-pre-command t) + (remove-hook 'pre-command-hook #'kmacro-step-edit-pre-command t) (when kmacro-step-edit-active - (add-hook 'pre-command-hook 'kmacro-step-edit-pre-command nil t))) + (add-hook 'pre-command-hook #'kmacro-step-edit-pre-command nil t))) (defun kmacro-step-edit-post-command () - (remove-hook 'pre-command-hook 'kmacro-step-edit-pre-command) + (remove-hook 'pre-command-hook #'kmacro-step-edit-pre-command) (when kmacro-step-edit-active - (add-hook 'pre-command-hook 'kmacro-step-edit-pre-command nil nil) + (add-hook 'pre-command-hook #'kmacro-step-edit-pre-command nil nil) (if kmacro-step-edit-key-index (setq executing-kbd-macro-index kmacro-step-edit-key-index) (setq kmacro-step-edit-key-index executing-kbd-macro-index)))) @@ -1262,9 +1265,9 @@ To customize possible responses, change the \"bindings\" in `kmacro-step-edit-ma (pre-command-hook pre-command-hook) (post-command-hook post-command-hook) (minibuffer-setup-hook minibuffer-setup-hook)) - (add-hook 'pre-command-hook 'kmacro-step-edit-pre-command nil) - (add-hook 'post-command-hook 'kmacro-step-edit-post-command t) - (add-hook 'minibuffer-setup-hook 'kmacro-step-edit-minibuf-setup t) + (add-hook 'pre-command-hook #'kmacro-step-edit-pre-command nil) + (add-hook 'post-command-hook #'kmacro-step-edit-post-command t) + (add-hook 'minibuffer-setup-hook #'kmacro-step-edit-minibuf-setup t) (call-last-kbd-macro nil nil) (when (and kmacro-step-edit-replace kmacro-step-edit-new-macro diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index 843f4c3cc25..c9669db20b0 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -5763,7 +5763,7 @@ It is possible to show this help automatically after some idle time. This is regulated by variable `cperl-lazy-help-time'. Default with `cperl-hairy' (if the value of `cperl-lazy-help-time' is nil) is 5 secs idle time . It is also possible to switch this on/off from the -menu, or via \\[cperl-toggle-autohelp]. Requires `run-with-idle-timer'. +menu, or via \\[cperl-toggle-autohelp]. Use \\[cperl-lineup] to vertically lineup some construction - put the beginning of the region at the start of construction, and make region @@ -8098,12 +8098,16 @@ the constant's documentation. \(fn M BS DOC &rest ARGS)" nil t) +(function-put 'easy-mmode-defmap 'lisp-indent-function '1) + (autoload 'easy-mmode-defsyntax "easy-mmode" "\ Define variable ST as a syntax-table. CSS contains a list of syntax specifications of the form (CHAR . SYNTAX). \(fn ST CSS DOC &rest ARGS)" nil t) +(function-put 'easy-mmode-defsyntax 'lisp-indent-function '1) + (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "easy-mmode" '("easy-mmode-"))) ;;;*** @@ -8332,7 +8336,7 @@ See also `ebnf-print-buffer'. (autoload 'ebnf-print-buffer "ebnf2ps" "\ Generate and print a PostScript syntactic chart image of the buffer. -When called with a numeric prefix argument (C-u), prompts the user for +When called with a numeric prefix argument (\\[universal-argument]), prompts the user for the name of a file to save the PostScript image in, instead of sending it to the printer. @@ -8454,7 +8458,7 @@ WARNING: This function does *NOT* ask any confirmation to override existing \(fn FROM TO)" t nil) -(defalias 'ebnf-despool 'ps-despool) +(defalias 'ebnf-despool #'ps-despool) (autoload 'ebnf-syntax-directory "ebnf2ps" "\ Do a syntactic analysis of the files in DIRECTORY. @@ -10610,10 +10614,9 @@ Otherwise, connect to HOST:PORT as USER and /join CHANNEL. ;;;*** -;;;### (autoloads nil "erc-autoaway" "erc/erc-autoaway.el" (0 0 0 -;;;;;; 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-autoaway" +;;;;;; "erc/erc-autoaway.el" (0 0 0 0)) ;;; Generated autoloads from erc/erc-autoaway.el - (autoload 'erc-autoaway-mode "erc-autoaway") (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-autoaway" '("erc-auto"))) @@ -10626,144 +10629,57 @@ Otherwise, connect to HOST:PORT as USER and /join CHANNEL. ;;;*** -;;;### (autoloads nil "erc-button" "erc/erc-button.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-button" "erc/erc-button.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-button.el - (autoload 'erc-button-mode "erc-button" nil t) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-button" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-capab" "erc/erc-capab.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-capab" "erc/erc-capab.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-capab.el - (autoload 'erc-capab-identify-mode "erc-capab" nil t) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-capab" '("erc-capab-identify-"))) ;;;*** -;;;### (autoloads nil "erc-compat" "erc/erc-compat.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-compat" "erc/erc-compat.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-compat.el - (autoload 'erc-define-minor-mode "erc-compat") (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-compat" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-dcc" "erc/erc-dcc.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-dcc" "erc/erc-dcc.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-dcc.el - (autoload 'erc-dcc-mode "erc-dcc") - -(autoload 'erc-cmd-DCC "erc-dcc" "\ -Parser for /dcc command. -This figures out the dcc subcommand and calls the appropriate routine to -handle it. The function dispatched should be named \"erc-dcc-do-FOO-command\", -where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc. - -\(fn CMD &rest ARGS)" nil nil) - -(autoload 'pcomplete/erc-mode/DCC "erc-dcc" "\ -Provides completion for the /DCC command. - -\(fn)" nil nil) - -(defvar erc-ctcp-query-DCC-hook '(erc-ctcp-query-DCC) "\ -Hook variable for CTCP DCC queries.") - -(autoload 'erc-ctcp-query-DCC "erc-dcc" "\ -The function called when a CTCP DCC request is detected by the client. -It examines the DCC subcommand, and calls the appropriate routine for -that subcommand. - -\(fn PROC NICK LOGIN HOST TO QUERY)" nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-dcc" '("erc-" "pcomplete/erc-mode/"))) ;;;*** -;;;### (autoloads nil "erc-desktop-notifications" "erc/erc-desktop-notifications.el" -;;;;;; (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-desktop-notifications" +;;;;;; "erc/erc-desktop-notifications.el" (0 0 0 0)) ;;; Generated autoloads from erc/erc-desktop-notifications.el -(autoload 'erc-notifications-mode "erc-desktop-notifications" "" t) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-desktop-notifications" '("erc-notifications-"))) ;;;*** -;;;### (autoloads nil "erc-ezbounce" "erc/erc-ezbounce.el" (0 0 0 -;;;;;; 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-ezbounce" +;;;;;; "erc/erc-ezbounce.el" (0 0 0 0)) ;;; Generated autoloads from erc/erc-ezbounce.el -(autoload 'erc-cmd-ezb "erc-ezbounce" "\ -Send EZB commands to the EZBouncer verbatim. - -\(fn LINE &optional FORCE)" nil nil) - -(autoload 'erc-ezb-get-login "erc-ezbounce" "\ -Return an appropriate EZBounce login for SERVER and PORT. -Look up entries in `erc-ezb-login-alist'. If the username or password -in the alist is nil, prompt for the appropriate values. - -\(fn SERVER PORT)" nil nil) - -(autoload 'erc-ezb-lookup-action "erc-ezbounce" "\ - - -\(fn MESSAGE)" nil nil) - -(autoload 'erc-ezb-notice-autodetect "erc-ezbounce" "\ -React on an EZBounce NOTICE request. - -\(fn PROC PARSED)" nil nil) - -(autoload 'erc-ezb-identify "erc-ezbounce" "\ -Identify to the EZBouncer server. - -\(fn MESSAGE)" nil nil) - -(autoload 'erc-ezb-init-session-list "erc-ezbounce" "\ -Reset the EZBounce session list to nil. - -\(fn MESSAGE)" nil nil) - -(autoload 'erc-ezb-end-of-session-list "erc-ezbounce" "\ -Indicate the end of the EZBounce session listing. - -\(fn MESSAGE)" nil nil) - -(autoload 'erc-ezb-add-session "erc-ezbounce" "\ -Add an EZBounce session to the session list. - -\(fn MESSAGE)" nil nil) - -(autoload 'erc-ezb-select "erc-ezbounce" "\ -Select an IRC server to use by EZBounce, in ERC style. - -\(fn MESSAGE)" nil nil) - -(autoload 'erc-ezb-select-session "erc-ezbounce" "\ -Select a detached EZBounce session. - -\(fn)" nil nil) - -(autoload 'erc-ezb-initialize "erc-ezbounce" "\ -Add EZBouncer convenience functions to ERC. - -\(fn)" nil nil) - (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-ezbounce" '("erc-ezb-"))) ;;;*** -;;;### (autoloads nil "erc-fill" "erc/erc-fill.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-fill" "erc/erc-fill.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-fill.el - (autoload 'erc-fill-mode "erc-fill" nil t) - -(autoload 'erc-fill "erc-fill" "\ -Fill a region using the function referenced in `erc-fill-function'. -You can put this on `erc-insert-modify-hook' and/or `erc-send-modify-hook'. - -\(fn)" nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-fill" '("erc-"))) @@ -10783,44 +10699,25 @@ You can put this on `erc-insert-modify-hook' and/or `erc-send-modify-hook'. ;;;*** -;;;### (autoloads nil "erc-identd" "erc/erc-identd.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-identd" "erc/erc-identd.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-identd.el - (autoload 'erc-identd-mode "erc-identd") - -(autoload 'erc-identd-start "erc-identd" "\ -Start an identd server listening to port 8113. -Port 113 (auth) will need to be redirected to port 8113 on your -machine -- using iptables, or a program like redir which can be -run from inetd. The idea is to provide a simple identd server -when you need one, without having to install one globally on your -system. - -\(fn &optional PORT)" t nil) - -(autoload 'erc-identd-stop "erc-identd" "\ - - -\(fn &rest IGNORE)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-identd" '("erc-identd-"))) ;;;*** -;;;### (autoloads nil "erc-imenu" "erc/erc-imenu.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-imenu" "erc/erc-imenu.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-imenu.el -(autoload 'erc-create-imenu-index "erc-imenu" "\ - - -\(fn)" nil nil) - (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-imenu" '("erc-unfill-notice"))) ;;;*** -;;;### (autoloads nil "erc-join" "erc/erc-join.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-join" "erc/erc-join.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-join.el - (autoload 'erc-autojoin-mode "erc-join" nil t) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-join" '("erc-"))) @@ -10833,110 +10730,41 @@ system. ;;;*** -;;;### (autoloads nil "erc-list" "erc/erc-list.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-list" "erc/erc-list.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-list.el - (autoload 'erc-list-mode "erc-list") (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-list" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-log" "erc/erc-log.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-log" "erc/erc-log.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-log.el - (autoload 'erc-log-mode "erc-log" nil t) - -(autoload 'erc-logging-enabled "erc-log" "\ -Return non-nil if logging is enabled for BUFFER. -If BUFFER is nil, the value of `current-buffer' is used. -Logging is enabled if `erc-log-channels-directory' is non-nil, the directory -is writable (it will be created as necessary) and -`erc-enable-logging' returns a non-nil value. - -\(fn &optional BUFFER)" nil nil) - -(autoload 'erc-save-buffer-in-logs "erc-log" "\ -Append BUFFER contents to the log file, if logging is enabled. -If BUFFER is not provided, current buffer is used. -Logging is enabled if `erc-logging-enabled' returns non-nil. - -This is normally done on exit, to save the unsaved portion of the -buffer, since only the text that runs off the buffer limit is logged -automatically. - -You can save every individual message by putting this function on -`erc-insert-post-hook'. - -\(fn &optional BUFFER)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-log" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-match" "erc/erc-match.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-match" "erc/erc-match.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-match.el - (autoload 'erc-match-mode "erc-match") - -(autoload 'erc-add-pal "erc-match" "\ -Add pal interactively to `erc-pals'. - -\(fn)" t nil) - -(autoload 'erc-delete-pal "erc-match" "\ -Delete pal interactively to `erc-pals'. - -\(fn)" t nil) - -(autoload 'erc-add-fool "erc-match" "\ -Add fool interactively to `erc-fools'. - -\(fn)" t nil) - -(autoload 'erc-delete-fool "erc-match" "\ -Delete fool interactively to `erc-fools'. - -\(fn)" t nil) - -(autoload 'erc-add-keyword "erc-match" "\ -Add keyword interactively to `erc-keywords'. - -\(fn)" t nil) - -(autoload 'erc-delete-keyword "erc-match" "\ -Delete keyword interactively to `erc-keywords'. - -\(fn)" t nil) - -(autoload 'erc-add-dangerous-host "erc-match" "\ -Add dangerous-host interactively to `erc-dangerous-hosts'. - -\(fn)" t nil) - -(autoload 'erc-delete-dangerous-host "erc-match" "\ -Delete dangerous-host interactively to `erc-dangerous-hosts'. - -\(fn)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-match" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-menu" "erc/erc-menu.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-menu" "erc/erc-menu.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-menu.el - (autoload 'erc-menu-mode "erc-menu" nil t) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-menu" '("erc-menu-"))) ;;;*** -;;;### (autoloads nil "erc-netsplit" "erc/erc-netsplit.el" (0 0 0 -;;;;;; 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-netsplit" +;;;;;; "erc/erc-netsplit.el" (0 0 0 0)) ;;; Generated autoloads from erc/erc-netsplit.el - (autoload 'erc-netsplit-mode "erc-netsplit") - -(autoload 'erc-cmd-WHOLEFT "erc-netsplit" "\ -Show who's gone. - -\(fn)" nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-netsplit" '("erc-"))) @@ -10962,176 +10790,105 @@ Interactively select a server to connect to using `erc-server-alist'. ;;;*** -;;;### (autoloads nil "erc-notify" "erc/erc-notify.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-notify" "erc/erc-notify.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-notify.el - (autoload 'erc-notify-mode "erc-notify" nil t) - -(autoload 'erc-cmd-NOTIFY "erc-notify" "\ -Change `erc-notify-list' or list current notify-list members online. -Without args, list the current list of notified people online, -with args, toggle notify status of people. - -\(fn &rest ARGS)" nil nil) - -(autoload 'pcomplete/erc-mode/NOTIFY "erc-notify" "\ - - -\(fn)" nil nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-notify" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-page" "erc/erc-page.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-page" "erc/erc-page.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-page.el - (autoload 'erc-page-mode "erc-page") (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-page" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-pcomplete" "erc/erc-pcomplete.el" (0 0 -;;;;;; 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-pcomplete" +;;;;;; "erc/erc-pcomplete.el" (0 0 0 0)) ;;; Generated autoloads from erc/erc-pcomplete.el - (autoload 'erc-completion-mode "erc-pcomplete" nil t) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-pcomplete" '("pcomplete" "erc-pcomplet"))) ;;;*** -;;;### (autoloads nil "erc-replace" "erc/erc-replace.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-replace" +;;;;;; "erc/erc-replace.el" (0 0 0 0)) ;;; Generated autoloads from erc/erc-replace.el - (autoload 'erc-replace-mode "erc-replace") (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-replace" '("erc-replace-"))) ;;;*** -;;;### (autoloads nil "erc-ring" "erc/erc-ring.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-ring" "erc/erc-ring.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-ring.el - (autoload 'erc-ring-mode "erc-ring" nil t) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-ring" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-services" "erc/erc-services.el" (0 0 0 -;;;;;; 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-services" +;;;;;; "erc/erc-services.el" (0 0 0 0)) ;;; Generated autoloads from erc/erc-services.el - (autoload 'erc-services-mode "erc-services" nil t) - -(autoload 'erc-nickserv-identify-mode "erc-services" "\ -Set up hooks according to which MODE the user has chosen. - -\(fn MODE)" t nil) - -(autoload 'erc-nickserv-identify "erc-services" "\ -Send an \"identify <PASSWORD>\" message to NickServ. -When called interactively, read the password using `read-passwd'. - -\(fn PASSWORD)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-services" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-sound" "erc/erc-sound.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-sound" "erc/erc-sound.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-sound.el - (autoload 'erc-sound-mode "erc-sound") (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-sound" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-speedbar" "erc/erc-speedbar.el" (0 0 0 -;;;;;; 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-speedbar" +;;;;;; "erc/erc-speedbar.el" (0 0 0 0)) ;;; Generated autoloads from erc/erc-speedbar.el -(autoload 'erc-speedbar-browser "erc-speedbar" "\ -Initialize speedbar to display an ERC browser. -This will add a speedbar major display mode. - -\(fn)" t nil) - (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-speedbar" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-spelling" "erc/erc-spelling.el" (0 0 0 -;;;;;; 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-spelling" +;;;;;; "erc/erc-spelling.el" (0 0 0 0)) ;;; Generated autoloads from erc/erc-spelling.el - (autoload 'erc-spelling-mode "erc-spelling" nil t) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-spelling" '("erc-spelling-"))) ;;;*** -;;;### (autoloads nil "erc-stamp" "erc/erc-stamp.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-stamp" "erc/erc-stamp.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-stamp.el - (autoload 'erc-timestamp-mode "erc-stamp" nil t) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-stamp" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-track" "erc/erc-track.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-track" "erc/erc-track.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-track.el -(defvar erc-track-minor-mode nil "\ -Non-nil if Erc-Track minor mode is enabled. -See the `erc-track-minor-mode' command -for a description of this minor mode.") - -(custom-autoload 'erc-track-minor-mode "erc-track" nil) - -(autoload 'erc-track-minor-mode "erc-track" "\ -Toggle mode line display of ERC activity (ERC Track minor mode). -With a prefix argument ARG, enable ERC Track minor mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. - -ERC Track minor mode is a global minor mode. It exists for the -sole purpose of providing the C-c C-SPC and C-c C-@ keybindings. -Make sure that you have enabled the track module, otherwise the -keybindings will not do anything useful. - -\(fn &optional ARG)" t nil) - (autoload 'erc-track-mode "erc-track" nil t) - (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-track" '("erc-"))) ;;;*** -;;;### (autoloads nil "erc-truncate" "erc/erc-truncate.el" (0 0 0 -;;;;;; 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-truncate" +;;;;;; "erc/erc-truncate.el" (0 0 0 0)) ;;; Generated autoloads from erc/erc-truncate.el - (autoload 'erc-truncate-mode "erc-truncate" nil t) - -(autoload 'erc-truncate-buffer-to-size "erc-truncate" "\ -Truncates the buffer to the size SIZE. -If BUFFER is not provided, the current buffer is assumed. The deleted -region is logged if `erc-logging-enabled' returns non-nil. - -\(fn SIZE &optional BUFFER)" nil nil) - -(autoload 'erc-truncate-buffer "erc-truncate" "\ -Truncates the current buffer to `erc-max-buffer-size'. -Meant to be used in hooks, like `erc-insert-post-hook'. - -\(fn)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-truncate" '("erc-max-buffer-size"))) ;;;*** -;;;### (autoloads nil "erc-xdcc" "erc/erc-xdcc.el" (0 0 0 0)) +;;;### (autoloads "actual autoloads are elsewhere" "erc-xdcc" "erc/erc-xdcc.el" +;;;;;; (0 0 0 0)) ;;; Generated autoloads from erc/erc-xdcc.el - (autoload 'erc-xdcc-mode "erc-xdcc") - -(autoload 'erc-xdcc-add-file "erc-xdcc" "\ -Add a file to `erc-xdcc-files'. - -\(fn FILE)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "erc-xdcc" '("erc-"))) @@ -12384,6 +12141,49 @@ Besides the choice of face, it is the same as `buffer-face-mode'. ;;;*** +;;;### (autoloads nil "faceup" "emacs-lisp/faceup.el" (0 0 0 0)) +;;; Generated autoloads from emacs-lisp/faceup.el +(push (purecopy '(faceup 0 0 6)) package--builtin-versions) + +(autoload 'faceup-view-buffer "faceup" "\ +Display the faceup representation of the current buffer. + +\(fn)" t nil) + +(autoload 'faceup-write-file "faceup" "\ +Save the faceup representation of the current buffer to the file FILE-NAME. + +Unless a name is given, the file will be named xxx.faceup, where +xxx is the file name associated with the buffer. + +If optional second arg CONFIRM is non-nil, this function +asks for confirmation before overwriting an existing file. +Interactively, confirmation is required unless you supply a prefix argument. + +\(fn &optional FILE-NAME CONFIRM)" t nil) + +(autoload 'faceup-render-view-buffer "faceup" "\ +Convert BUFFER containing Faceup markup to a new buffer and display it. + +\(fn &optional BUFFER)" t nil) + +(autoload 'faceup-clean-buffer "faceup" "\ +Remove faceup markup from buffer. + +\(fn)" t nil) + +(autoload 'faceup-defexplainer "faceup" "\ +Define an Ert explainer function for FUNCTION. + +FUNCTION must return an explanation when the test fails and +`faceup-test-explain' is set. + +\(fn FUNCTION)" nil t) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "faceup" '("faceup-"))) + +;;;*** + ;;;### (autoloads nil "feedmail" "mail/feedmail.el" (0 0 0 0)) ;;; Generated autoloads from mail/feedmail.el (push (purecopy '(feedmail 11)) package--builtin-versions) @@ -12543,7 +12343,7 @@ STRING is passed as an argument to the locate command. \(fn STRING)" t nil) (autoload 'file-cache-add-directory-recursively "filecache" "\ -Adds DIR and any subdirectories to the file-cache. +Add DIR and any subdirectories to the file-cache. This function does not use any external programs. If the optional REGEXP argument is non-nil, only files which match it will be added to the cache. Note that the REGEXP is applied to the @@ -13465,7 +13265,7 @@ play around with the following keys: \(fn &optional ARG)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "footnote" '("footnote-" "Footnote-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "footnote" '("footnote-"))) ;;;*** @@ -16797,7 +16597,7 @@ You may also want to set `hfy-page-header' and `hfy-page-footer'. ;;;;;; (0 0 0 0)) ;;; Generated autoloads from ibuf-ext.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ibuf-ext" '("ibuffer-" "file" "shell-command-" "starred-name" "size" "alphabetic" "major-mode" "mod" "print" "predicate" "content" "view-and-eval" "visiting-file" "derived-mode" "directory" "basename" "name" "used-mode" "query-replace" "rename-uniquely" "revert" "replace-regexp" "eval"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ibuf-ext" '("ibuffer-" "file" "shell-command-" "starred-name" "size" "alphabetic" "major-mode" "mod" "print" "process" "predicate" "content" "view-and-eval" "visiting-file" "derived-mode" "directory" "basename" "name" "used-mode" "query-replace" "rename-uniquely" "revert" "replace-regexp" "eval"))) ;;;*** @@ -20005,13 +19805,7 @@ A major mode to edit m4 macro files. ;;;### (autoloads nil "macros" "macros.el" (0 0 0 0)) ;;; Generated autoloads from macros.el -(autoload 'name-last-kbd-macro "macros" "\ -Assign a name to the last keyboard macro defined. -Argument SYMBOL is the name to define. -The symbol's function definition becomes the keyboard macro string. -Such a \"function\" cannot be called from Lisp, but it is a valid editor command. - -\(fn SYMBOL)" t nil) +(defalias 'name-last-kbd-macro #'kmacro-name-last-macro) (autoload 'insert-kbd-macro "macros" "\ Insert in buffer the definition of kbd macro MACRONAME, as Lisp code. @@ -33058,10 +32852,8 @@ use in that buffer. ;;; Generated autoloads from emacs-lisp/testcover.el (autoload 'testcover-start "testcover" "\ -Uses edebug to instrument all macros and functions in FILENAME, then -changes the instrumentation from edebug to testcover--much faster, no -problems with type-ahead or post-command-hook, etc. If BYTE-COMPILE is -non-nil, byte-compiles each function after instrumenting. +Use Edebug to instrument for coverage all macros and functions in FILENAME. +If BYTE-COMPILE is non-nil, byte compile each function after instrumenting. \(fn FILENAME &optional BYTE-COMPILE)" t nil) @@ -33639,7 +33431,7 @@ Return the Lisp list at point, or nil if none is found. \(fn)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "thingatpt" '("form-at-point" "thing-at-point-" "sentence-at-point" "word-at-point" "in-string-p" "end-of-thing" "beginning-of-thing"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "thingatpt" '("filename" "form-at-point" "thing-at-point-" "sentence-at-point" "word-at-point" "define-thing-chars" "in-string-p" "end-of-thing" "beginning-of-thing"))) ;;;*** @@ -34490,7 +34282,7 @@ Add Tramp file name handlers to `file-name-handler-alist' during autoload." (add (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 (quote (tramp-file-name-handler tramp-completion-file-name-handler tramp-autoload-file-name-handler))) (let ((a1 (rassq fnh file-name-handler-alist))) (setq file-name-handler-alist (delq a1 file-name-handler-alist))))) +Unload Tramp file name handlers from `file-name-handler-alist'." (dolist (fnh (quote (tramp-file-name-handler tramp-completion-file-name-handler tramp-archive-file-name-handler tramp-autoload-file-name-handler))) (let ((a1 (rassq fnh file-name-handler-alist))) (setq file-name-handler-alist (delq a1 file-name-handler-alist))))) (defvar tramp-completion-mode nil "\ If non-nil, external packages signal that they are in file name completion.") @@ -34511,6 +34303,14 @@ Discard Tramp from loading remote files. ;;;*** +;;;### (autoloads nil "tramp-archive" "net/tramp-archive.el" (0 0 +;;;;;; 0 0)) +;;; Generated autoloads from net/tramp-archive.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-archive" '("tramp-" "with-parsed-tramp-archive-file-name"))) + +;;;*** + ;;;### (autoloads nil "tramp-cache" "net/tramp-cache.el" (0 0 0 0)) ;;; Generated autoloads from net/tramp-cache.el @@ -34575,7 +34375,7 @@ Reenable Ange-FTP, when Tramp is unloaded. ;;;### (autoloads nil "trampver" "net/trampver.el" (0 0 0 0)) ;;; Generated autoloads from net/trampver.el -(push (purecopy '(tramp 2 3 3 26 1)) package--builtin-versions) +(push (purecopy '(tramp 2 4 0 -1)) package--builtin-versions) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "trampver" '("tramp-"))) @@ -38640,52 +38440,70 @@ Zone out, completely. ;;;;;; "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" "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/charscript.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" -;;;;;; "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" -;;;;;; "language/indian.el" "language/japanese.el" "language/khmer.el" -;;;;;; "language/korean.el" "language/lao.el" "language/misc-lang.el" -;;;;;; "language/romanian.el" "language/sinhala.el" "language/slovak.el" -;;;;;; "language/tai-viet.el" "language/thai.el" "language/tibetan.el" -;;;;;; "language/utf-8-lang.el" "language/vietnamese.el" "ldefs-boot.el" -;;;;;; "leim/ja-dic/ja-dic.el" "leim/leim-list.el" "leim/quail/4Corner.el" -;;;;;; "leim/quail/ARRAY30.el" "leim/quail/CCDOSPY.el" "leim/quail/CTLau-b5.el" -;;;;;; "leim/quail/CTLau.el" "leim/quail/ECDICT.el" "leim/quail/ETZY.el" -;;;;;; "leim/quail/PY-b5.el" "leim/quail/PY.el" "leim/quail/Punct-b5.el" -;;;;;; "leim/quail/Punct.el" "leim/quail/QJ-b5.el" "leim/quail/QJ.el" -;;;;;; "leim/quail/SW.el" "leim/quail/TONEPY.el" "leim/quail/ZIRANMA.el" -;;;;;; "leim/quail/ZOZY.el" "leim/quail/arabic.el" "leim/quail/croatian.el" -;;;;;; "leim/quail/cyril-jis.el" "leim/quail/cyrillic.el" "leim/quail/czech.el" -;;;;;; "leim/quail/georgian.el" "leim/quail/greek.el" "leim/quail/hanja-jis.el" -;;;;;; "leim/quail/hanja.el" "leim/quail/hanja3.el" "leim/quail/hebrew.el" -;;;;;; "leim/quail/ipa-praat.el" "leim/quail/latin-alt.el" "leim/quail/latin-ltx.el" -;;;;;; "leim/quail/latin-post.el" "leim/quail/latin-pre.el" "leim/quail/persian.el" -;;;;;; "leim/quail/programmer-dvorak.el" "leim/quail/py-punct.el" -;;;;;; "leim/quail/pypunct-b5.el" "leim/quail/quick-b5.el" "leim/quail/quick-cns.el" -;;;;;; "leim/quail/rfc1345.el" "leim/quail/sgml-input.el" "leim/quail/slovak.el" -;;;;;; "leim/quail/symbol-ksc.el" "leim/quail/tamil-dvorak.el" "leim/quail/tsang-b5.el" -;;;;;; "leim/quail/tsang-cns.el" "leim/quail/vntelex.el" "leim/quail/vnvni.el" -;;;;;; "leim/quail/welsh.el" "loadup.el" "mail/blessmail.el" "mail/rmailedit.el" -;;;;;; "mail/rmailkwd.el" "mail/rmailmm.el" "mail/rmailmsc.el" "mail/rmailsort.el" -;;;;;; "mail/rmailsum.el" "mail/undigest.el" "menu-bar.el" "mh-e/mh-gnus.el" -;;;;;; "mh-e/mh-loaddefs.el" "minibuffer.el" "mouse.el" "net/tramp-loaddefs.el" -;;;;;; "newcomment.el" "obarray.el" "org/ob-core.el" "org/ob-keys.el" -;;;;;; "org/ob-lob.el" "org/ob-matlab.el" "org/ob-tangle.el" "org/ob.el" -;;;;;; "org/org-archive.el" "org/org-attach.el" "org/org-bbdb.el" -;;;;;; "org/org-clock.el" "org/org-datetree.el" "org/org-element.el" -;;;;;; "org/org-feed.el" "org/org-footnote.el" "org/org-id.el" "org/org-indent.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-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" "language/indian.el" "language/japanese.el" +;;;;;; "language/khmer.el" "language/korean.el" "language/lao.el" +;;;;;; "language/misc-lang.el" "language/romanian.el" "language/sinhala.el" +;;;;;; "language/slovak.el" "language/tai-viet.el" "language/thai.el" +;;;;;; "language/tibetan.el" "language/utf-8-lang.el" "language/vietnamese.el" +;;;;;; "ldefs-boot.el" "leim/ja-dic/ja-dic.el" "leim/leim-list.el" +;;;;;; "leim/quail/4Corner.el" "leim/quail/ARRAY30.el" "leim/quail/CCDOSPY.el" +;;;;;; "leim/quail/CTLau-b5.el" "leim/quail/CTLau.el" "leim/quail/ECDICT.el" +;;;;;; "leim/quail/ETZY.el" "leim/quail/PY-b5.el" "leim/quail/PY.el" +;;;;;; "leim/quail/Punct-b5.el" "leim/quail/Punct.el" "leim/quail/QJ-b5.el" +;;;;;; "leim/quail/QJ.el" "leim/quail/SW.el" "leim/quail/TONEPY.el" +;;;;;; "leim/quail/ZIRANMA.el" "leim/quail/ZOZY.el" "leim/quail/arabic.el" +;;;;;; "leim/quail/croatian.el" "leim/quail/cyril-jis.el" "leim/quail/cyrillic.el" +;;;;;; "leim/quail/czech.el" "leim/quail/georgian.el" "leim/quail/greek.el" +;;;;;; "leim/quail/hanja-jis.el" "leim/quail/hanja.el" "leim/quail/hanja3.el" +;;;;;; "leim/quail/hebrew.el" "leim/quail/ipa-praat.el" "leim/quail/latin-alt.el" +;;;;;; "leim/quail/latin-ltx.el" "leim/quail/latin-post.el" "leim/quail/latin-pre.el" +;;;;;; "leim/quail/persian.el" "leim/quail/programmer-dvorak.el" +;;;;;; "leim/quail/py-punct.el" "leim/quail/pypunct-b5.el" "leim/quail/quick-b5.el" +;;;;;; "leim/quail/quick-cns.el" "leim/quail/rfc1345.el" "leim/quail/sgml-input.el" +;;;;;; "leim/quail/slovak.el" "leim/quail/symbol-ksc.el" "leim/quail/tamil-dvorak.el" +;;;;;; "leim/quail/tsang-b5.el" "leim/quail/tsang-cns.el" "leim/quail/vntelex.el" +;;;;;; "leim/quail/vnvni.el" "leim/quail/welsh.el" "loadup.el" "mail/blessmail.el" +;;;;;; "mail/rmailedit.el" "mail/rmailkwd.el" "mail/rmailmm.el" +;;;;;; "mail/rmailmsc.el" "mail/rmailsort.el" "mail/rmailsum.el" +;;;;;; "mail/undigest.el" "menu-bar.el" "mh-e/mh-gnus.el" "mh-e/mh-loaddefs.el" +;;;;;; "minibuffer.el" "mouse.el" "net/tramp-loaddefs.el" "newcomment.el" +;;;;;; "obarray.el" "org/ob-core.el" "org/ob-keys.el" "org/ob-lob.el" +;;;;;; "org/ob-matlab.el" "org/ob-tangle.el" "org/ob.el" "org/org-archive.el" +;;;;;; "org/org-attach.el" "org/org-bbdb.el" "org/org-clock.el" +;;;;;; "org/org-datetree.el" "org/org-element.el" "org/org-feed.el" +;;;;;; "org/org-footnote.el" "org/org-id.el" "org/org-indent.el" ;;;;;; "org/org-install.el" "org/org-irc.el" "org/org-mobile.el" ;;;;;; "org/org-plot.el" "org/org-table.el" "org/org-timer.el" "org/ox-ascii.el" ;;;;;; "org/ox-beamer.el" "org/ox-html.el" "org/ox-icalendar.el" diff --git a/lisp/macros.el b/lisp/macros.el index 29314d53c29..4078b983ec6 100644 --- a/lisp/macros.el +++ b/lisp/macros.el @@ -1,4 +1,4 @@ -;;; macros.el --- non-primitive commands for keyboard macros +;;; macros.el --- non-primitive commands for keyboard macros -*- lexical-binding:t -*- ;; Copyright (C) 1985-1987, 1992, 1994-1995, 2001-2018 Free Software ;; Foundation, Inc. @@ -31,23 +31,10 @@ ;;; Code: +(require 'kmacro) + ;;;###autoload -(defun name-last-kbd-macro (symbol) - "Assign a name to the last keyboard macro defined. -Argument SYMBOL is the name to define. -The symbol's function definition becomes the keyboard macro string. -Such a \"function\" cannot be called from Lisp, but it is a valid editor command." - (interactive "SName for last kbd macro: ") - (or last-kbd-macro - (user-error "No keyboard macro defined")) - (and (fboundp symbol) - (not (stringp (symbol-function symbol))) - (not (vectorp (symbol-function symbol))) - (user-error "Function %s is already defined and not a keyboard macro" - symbol)) - (if (string-equal symbol "") - (user-error "No command name given")) - (fset symbol last-kbd-macro)) +(defalias 'name-last-kbd-macro #'kmacro-name-last-macro) ;;;###autoload (defun insert-kbd-macro (macroname &optional keys) @@ -66,11 +53,7 @@ To save a kbd macro, visit a file of Lisp code such as your `~/.emacs', use this command, and then save the file." (interactive (list (intern (completing-read "Insert kbd macro (name): " obarray - (lambda (elt) - (and (fboundp elt) - (or (stringp (symbol-function elt)) - (vectorp (symbol-function elt)) - (get elt 'kmacro)))) + #'kmacro-keyboard-macro-p t)) current-prefix-arg)) (let (definition) @@ -137,6 +120,9 @@ use this command, and then save the file." (prin1 char (current-buffer)) (princ (prin1-char char) (current-buffer)))) (insert ?\])) + ;; FIXME: For kmacros, we shouldn't write the (lambda ...) + ;; gunk but instead we should write something more abstract like + ;; (kmacro-create [<keys>] 0 "%d"). (prin1 definition (current-buffer)))) (insert ")\n") (if keys diff --git a/lisp/mail/binhex.el b/lisp/mail/binhex.el index 04044042e9a..299fc0b2341 100644 --- a/lisp/mail/binhex.el +++ b/lisp/mail/binhex.el @@ -1,4 +1,4 @@ -;;; binhex.el --- decode BinHex-encoded text +;;; binhex.el --- decode BinHex-encoded text -*- lexical-binding:t -*- ;; Copyright (C) 1998-2018 Free Software Foundation, Inc. @@ -29,8 +29,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) - (eval-and-compile (defalias 'binhex-char-int (if (fboundp 'char-int) @@ -193,7 +191,7 @@ input and write the converted data to its standard output." (defvar binhex-last-char) (defvar binhex-repeat) -(defun binhex-push-char (char &optional count ignored buffer) +(defun binhex-push-char (char &optional ignored buffer) (cond (binhex-repeat (if (eq char 0) @@ -241,10 +239,10 @@ If HEADER-ONLY is non-nil only decode header and return filename." counter (1+ counter) inputpos (1+ inputpos)) (cond ((= counter 4) - (binhex-push-char (lsh bits -16) 1 nil work-buffer) - (binhex-push-char (logand (lsh bits -8) 255) 1 nil + (binhex-push-char (lsh bits -16) nil work-buffer) + (binhex-push-char (logand (lsh bits -8) 255) nil work-buffer) - (binhex-push-char (logand bits 255) 1 nil + (binhex-push-char (logand bits 255) nil work-buffer) (setq bits 0 counter 0)) (t (setq bits (lsh bits 6))))) @@ -263,12 +261,12 @@ If HEADER-ONLY is non-nil only decode header and return filename." (setq tmp (and tmp (not (eq inputpos end))))) (cond ((= counter 3) - (binhex-push-char (logand (lsh bits -16) 255) 1 nil + (binhex-push-char (logand (lsh bits -16) 255) nil work-buffer) - (binhex-push-char (logand (lsh bits -8) 255) 1 nil + (binhex-push-char (logand (lsh bits -8) 255) nil work-buffer)) ((= counter 2) - (binhex-push-char (logand (lsh bits -10) 255) 1 nil + (binhex-push-char (logand (lsh bits -10) 255) nil work-buffer)))) (if header-only nil (binhex-verify-crc work-buffer @@ -287,7 +285,7 @@ If HEADER-ONLY is non-nil only decode header and return filename." (defun binhex-decode-region-external (start end) "Binhex decode region between START and END using external decoder." (interactive "r") - (let ((cbuf (current-buffer)) firstline work-buffer status + (let ((cbuf (current-buffer)) firstline work-buffer (file-name (expand-file-name (concat (binhex-decode-region-internal start end t) ".data") diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el index 503919106f0..cb34a75fa1c 100644 --- a/lisp/mail/emacsbug.el +++ b/lisp/mail/emacsbug.el @@ -232,13 +232,32 @@ usually do not have translators for other languages.\n\n"))) "', version " (mapconcat 'number-to-string (x-server-version) ".") "\n") (error t))) - (let ((lsb (with-temp-buffer - (if (eq 0 (ignore-errors - (call-process "lsb_release" nil '(t nil) - nil "-d"))) - (buffer-string))))) - (if (stringp lsb) - (insert "System " lsb "\n"))) + (let (os) + ;; Maybe this should be factored out in a standalone function, + ;; eg emacs-os-description. + (cond ((eq system-type 'darwin) + (with-temp-buffer + (when (eq 0 (ignore-errors + (call-process "sw_vers" nil '(t nil) nil))) + (dolist (s '("ProductName" "ProductVersion")) + (goto-char (point-min)) + (if (re-search-forward (format "^%s\\s-*:\\s-+\\(.*\\)$" s) + nil t) + (setq os (concat os " " (match-string 1)))))))) + ;; TODO include other branches here. + ;; MS Windows: systeminfo ? + ;; Cygwin, *BSD, etc: ? + (t + (with-temp-buffer + (when (eq 0 (ignore-errors + (call-process "lsb_release" nil '(t nil) + nil "-d"))) + (goto-char (point-min)) + (if (looking-at "^\\sw+:\\s-+") + (goto-char (match-end 0))) + (setq os (buffer-substring (point) (line-end-position))))))) + (if (stringp os) + (insert "System Description: " os "\n\n"))) (let ((message-buf (get-buffer "*Messages*"))) (if message-buf (let (beg-pos diff --git a/lisp/mail/flow-fill.el b/lisp/mail/flow-fill.el index 65f2421cb9a..db2a30ad15e 100644 --- a/lisp/mail/flow-fill.el +++ b/lisp/mail/flow-fill.el @@ -1,4 +1,4 @@ -;;; flow-fill.el --- interpret RFC2646 "flowed" text +;;; flow-fill.el --- interpret RFC2646 "flowed" text -*- lexical-binding:t -*- ;; Copyright (C) 2000-2018 Free Software Foundation, Inc. @@ -49,7 +49,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (defcustom fill-flowed-display-column 'fill-column "Column beyond which format=flowed lines are wrapped, when displayed. diff --git a/lisp/mail/footnote.el b/lisp/mail/footnote.el index 5a04eea25ac..d35b87046fe 100644 --- a/lisp/mail/footnote.el +++ b/lisp/mail/footnote.el @@ -1,8 +1,9 @@ -;;; footnote.el --- footnote support for message mode +;;; footnote.el --- footnote support for message mode -*- lexical-binding:t -*- ;; Copyright (C) 1997, 2000-2018 Free Software Foundation, Inc. -;; Author: Steven L Baur <steve@xemacs.org> +;; Author: Steven L Baur <steve@xemacs.org> (1997-2011) +;; Boruch Baum <boruch_baum@gmx.com> (2017-) ;; Keywords: mail, news ;; Version: 0.19 @@ -29,9 +30,36 @@ ;; [1] Footnotes look something like this. Along with some decorative ;; stuff. -;; TODO: -;; Reasonable Undo support. -;; more language styles. +;;;; TODO: +;; + Reasonable Undo support. +;; - could use an `apply' entry in the buffer-undo-list to be warned when +;; a footnote we inserted is removed via undo. +;; - should try to handle the more general problem of deleting/removing +;; footnotes via standard editing commands rather than via footnote +;; commands. +;; + more language styles. +;; + The key sequence 'C-c ! a C-y C-c ! b' should auto-fill the +;; footnote in adaptive fill mode. This does not seem to be a bug in +;; `adaptive-fill' because it behaves that way on all point movements +;; + Handle footmode mode elegantly in all modes, even if that means refuses to +;; accept the burden. For example, in a programming language mode, footnotes +;; should be commented. +;; + Manually autofilling the a first footnote should not cause it to +;; wrap into the footnote section tag +;; + Current solution adds a second newline after the section tag, so it is +;; clearly a separate paragraph. There may be stylistic objections to this. +;; + Footnotes with multiple paragraphs should not have their first +;; line out-dented. +;; + Upon leaving footnote area, perform an auto-fill on an entire +;; footnote (including multiple paragraphs), or on entire footnote area. +;; + fill-paragraph takes arg REGION, but seemingly only when called +;; interactively. +;; + At some point, it became necessary to change `footnote-section-tag-regexp' +;; to remove its trailing space. (Adaptive fill side-effect?) +;; + useful for lazy testing +;; (setq footnote-narrow-to-footnotes-when-editing t) +;; (setq footnote-section-tag "Footnotes: ") +;; (setq footnote-section-tag-regexp "Footnotes\\(\\[.\\]\\)?:") ;;; Code: @@ -92,20 +120,25 @@ After that, changing the prefix key requires manipulating keymaps." ;;; Interface variables that probably shouldn't be changed -(defcustom footnote-section-tag "Footnotes: " +(defcustom footnote-section-tag "Footnotes:" "Tag inserted at beginning of footnote section. If you set this to the empty string, no tag is inserted and the value of `footnote-section-tag-regexp' is ignored. Customizing this variable has no effect on buffers already displaying footnotes." + :version "27.1" :type 'string :group 'footnote) -(defcustom footnote-section-tag-regexp "Footnotes\\(\\[.\\]\\)?: " +(defcustom footnote-section-tag-regexp + ;; Even if `footnote-section-tag' has a trailing space, let's not require it + ;; here, since it might be trimmed by various commands. + "Footnotes\\(\\[.\\]\\)?:" "Regexp which indicates the start of a footnote section. This variable is disregarded when `footnote-section-tag' is the empty string. Customizing this variable has no effect on buffers already displaying footnotes." + :version "27.1" :type 'regexp :group 'footnote) @@ -124,13 +157,21 @@ has no effect on buffers already displaying footnotes." :type 'string :group 'footnote) -(defcustom footnote-signature-separator (if (boundp 'message-signature-separator) - message-signature-separator - "^-- $") +(defcustom footnote-signature-separator + (if (boundp 'message-signature-separator) + message-signature-separator + "^-- $") "Regexp used by Footnote mode to recognize signatures." :type 'regexp :group 'footnote) +(defcustom footnote-align-to-fn-text t + "How to left-align footnote text. +If nil, footnote text is to be aligned flush left with left side +of the footnote number. If non-nil, footnote text is to be aligned +left with the first character of footnote text." + :type 'boolean) + ;;; Private variables (defvar footnote-style-number nil @@ -148,12 +189,14 @@ has no effect on buffers already displaying footnotes." (defvar footnote-mouse-highlight 'highlight "Text property name to enable mouse over highlight.") +(defvar footnote-mode) + ;;; Default styles ;;; NUMERIC (defconst footnote-numeric-regexp "[0-9]+" "Regexp for digits.") -(defun Footnote-numeric (n) +(defun footnote--numeric (n) "Numeric footnote style. Use Arabic numerals for footnoting." (int-to-string n)) @@ -165,7 +208,7 @@ Use Arabic numerals for footnoting." (defconst footnote-english-upper-regexp "[A-Z]+" "Regexp for upper case English alphabet.") -(defun Footnote-english-upper (n) +(defun footnote--english-upper (n) "Upper case English footnoting. Wrapping around the alphabet implies successive repetitions of letters." (let* ((ltr (mod (1- n) (length footnote-english-upper))) @@ -184,7 +227,7 @@ Wrapping around the alphabet implies successive repetitions of letters." (defconst footnote-english-lower-regexp "[a-z]+" "Regexp of lower case English alphabet.") -(defun Footnote-english-lower (n) +(defun footnote--english-lower (n) "Lower case English footnoting. Wrapping around the alphabet implies successive repetitions of letters." (let* ((ltr (mod (1- n) (length footnote-english-lower))) @@ -202,27 +245,28 @@ Wrapping around the alphabet implies successive repetitions of letters." (50 . "l") (100 . "c") (500 . "d") (1000 . "m")) "List of roman numerals with their values.") -(defconst footnote-roman-lower-regexp "[ivxlcdm]+" +(defconst footnote-roman-lower-regexp + (concat "[" (mapconcat #'cdr footnote-roman-lower-list "") "]+") "Regexp of roman numerals.") -(defun Footnote-roman-lower (n) +(defun footnote--roman-lower (n) "Generic Roman number footnoting." - (Footnote-roman-common n footnote-roman-lower-list)) + (footnote--roman-common n footnote-roman-lower-list)) ;;; ROMAN UPPER (defconst footnote-roman-upper-list - '((1 . "I") (5 . "V") (10 . "X") - (50 . "L") (100 . "C") (500 . "D") (1000 . "M")) + (mapcar (lambda (x) (cons (car x) (upcase (cdr x)))) + footnote-roman-lower-list) "List of roman numerals with their values.") -(defconst footnote-roman-upper-regexp "[IVXLCDM]+" +(defconst footnote-roman-upper-regexp (upcase footnote-roman-lower-regexp) "Regexp of roman numerals. Not complete") -(defun Footnote-roman-upper (n) +(defun footnote--roman-upper (n) "Generic Roman number footnoting." - (Footnote-roman-common n footnote-roman-upper-list)) + (footnote--roman-common n footnote-roman-upper-list)) -(defun Footnote-roman-common (n footnote-roman-list) +(defun footnote--roman-common (n footnote-roman-list) "Lower case Roman footnoting." (let* ((our-list footnote-roman-list) (rom-lngth (length our-list)) @@ -257,22 +301,22 @@ Wrapping around the alphabet implies successive repetitions of letters." ;; (message "pairs are: rom-low: %S, rom-high: %S, rom-div: %S" ;; rom-low-pair rom-high-pair rom-div-pair) (cond - ((< n 0) (error "Footnote-roman-common called with n < 0")) + ((< n 0) (error "footnote--roman-common called with n < 0")) ((= n 0) "") ((= n (car rom-low-pair)) (cdr rom-low-pair)) ((= n (car rom-high-pair)) (cdr rom-high-pair)) ((= (car rom-low-pair) (car rom-high-pair)) (concat (cdr rom-low-pair) - (Footnote-roman-common + (footnote--roman-common (- n (car rom-low-pair)) footnote-roman-list))) ((>= rom-div 0) (concat (cdr rom-div-pair) (cdr rom-high-pair) - (Footnote-roman-common + (footnote--roman-common (- n (- (car rom-high-pair) (car rom-div-pair))) footnote-roman-list))) (t (concat (cdr rom-low-pair) - (Footnote-roman-common + (footnote--roman-common (- n (car rom-low-pair)) footnote-roman-list))))))) @@ -285,7 +329,7 @@ Wrapping around the alphabet implies successive repetitions of letters." (defconst footnote-latin-regexp (concat "[" footnote-latin-string "]") "Regexp for Latin-1 footnoting characters.") -(defun Footnote-latin (n) +(defun footnote--latin (n) "Latin-1 footnote style. Use a range of Latin-1 non-ASCII characters for footnoting." (string (aref footnote-latin-string @@ -299,7 +343,7 @@ Use a range of Latin-1 non-ASCII characters for footnoting." (defconst footnote-unicode-regexp (concat "[" footnote-unicode-string "]+") "Regexp for Unicode footnoting characters.") -(defun Footnote-unicode (n) +(defun footnote--unicode (n) "Unicode footnote style. Use Unicode characters for footnoting." (let (modulus result done) @@ -310,18 +354,70 @@ Use Unicode characters for footnoting." (push (aref footnote-unicode-string modulus) result)) (apply #'string result))) +;; Hebrew + +(defconst footnote-hebrew-numeric + '( + ("א" "ב" "ג" "ד" "ה" "ו" "ז" "ח" "ט") + ("י" "כ" "ל" "מ" "נ" "ס" "ע" "פ" "צ") + ("ק" "ר" "ש" "ת" "תק" "תר" "תש" "תת" "תתק"))) + +(defconst footnote-hebrew-numeric-regex + (concat "[" (apply #'concat (apply #'append footnote-hebrew-numeric)) "']+")) +;; (defconst footnote-hebrew-numeric-regex "\\([אבגדהוזחט]'\\)?\\(ת\\)?\\(ת\\)?\\([קרשת]\\)?\\([טיכלמנסעפצ]\\)?\\([אבגדהוזחט]\\)?") + +(defun footnote--hebrew-numeric (n) + "Supports 9999 footnotes, then rolls over." + (let* ((n (+ (mod n 10000) (/ n 10000))) + (thousands (/ n 1000)) + (hundreds (/ (mod n 1000) 100)) + (tens (/ (mod n 100) 10)) + (units (mod n 10)) + (special (cond + ((not (= tens 1)) nil) + ((= units 5) "טו") + ((= units 6) "טז")))) + (concat + (when (/= 0 thousands) + (concat (nth (1- thousands) (nth 0 footnote-hebrew-numeric)) "'")) + (when (/= 0 hundreds) + (nth (1- hundreds) (nth 2 footnote-hebrew-numeric))) + (or special + (concat + (when (/= 0 tens) (nth (1- tens) (nth 1 footnote-hebrew-numeric))) + (when (/= 0 units) (nth (1- units) (nth 0 footnote-hebrew-numeric)))))))) + +(defconst footnote-hebrew-symbolic + '( + "א" "ב" "ג" "ד" "ה" "ו" "ז" "ח" "ט" "י" "כ" "ל" "מ" "נ" "ס" "ע" "פ" "צ" "ק" "ר" "ש" "ת")) + +(defconst footnote-hebrew-symbolic-regex + (concat "[" (apply #'concat footnote-hebrew-symbolic) "]")) + +(defun footnote--hebrew-symbolic (n) + "Only 22 elements, per the style of eg. 'פירוש שפתי חכמים על רש״י'. +Proceeds from `י' to `כ', from `צ' to `ק'. After `ת', rolls over to `א'." + (nth (mod (1- n) 22) footnote-hebrew-symbolic)) + ;;; list of all footnote styles (defvar footnote-style-alist - `((numeric Footnote-numeric ,footnote-numeric-regexp) - (english-lower Footnote-english-lower ,footnote-english-lower-regexp) - (english-upper Footnote-english-upper ,footnote-english-upper-regexp) - (roman-lower Footnote-roman-lower ,footnote-roman-lower-regexp) - (roman-upper Footnote-roman-upper ,footnote-roman-upper-regexp) - (latin Footnote-latin ,footnote-latin-regexp) - (unicode Footnote-unicode ,footnote-unicode-regexp)) + `((numeric footnote--numeric ,footnote-numeric-regexp) + (english-lower footnote--english-lower ,footnote-english-lower-regexp) + (english-upper footnote--english-upper ,footnote-english-upper-regexp) + (roman-lower footnote--roman-lower ,footnote-roman-lower-regexp) + (roman-upper footnote--roman-upper ,footnote-roman-upper-regexp) + (latin footnote--latin ,footnote-latin-regexp) + (unicode footnote--unicode ,footnote-unicode-regexp) + (hebrew-numeric footnote--hebrew-numeric ,footnote-hebrew-numeric-regex) + (hebrew-symbolic footnote--hebrew-symbolic ,footnote-hebrew-symbolic-regex)) "Styles of footnote tags available. -By default only boring Arabic numbers, English letters and Roman Numerals -are available.") +By default, Arabic numbers, English letters, Roman Numerals, +Latin and Unicode superscript characters, and Hebrew numerals +are available. +Each element of the list should be of the form (NAME FUNCTION REGEXP) +where NAME is a symbol, FUNCTION takes a footnote number and +returns the corresponding representation in that style as a string, +and REGEXP should be a regexp that matches any output of FUNCTION.") (defcustom footnote-style 'numeric "Default style used for footnoting. @@ -332,6 +428,8 @@ roman-lower == i, ii, iii, iv, v, ... roman-upper == I, II, III, IV, V, ... latin == ¹ ² ³ º ª § ¶ unicode == ¹, ², ³, ... +hebrew-numeric == א, ב, ..., יא, ..., תקא... +hebrew-symbolic == א, ב, ..., י, כ, ..., צ, ק, ..., ת, א See also variables `footnote-start-tag' and `footnote-end-tag'. Note: some characters in the unicode style may not show up @@ -339,36 +437,36 @@ properly if the default font does not contain those characters. Customizing this variable has no effect on buffers already displaying footnotes. To change the style of footnotes in such a -buffer use the command `Footnote-set-style'." +buffer use the command `footnote-set-style'." :type (cons 'choice (mapcar (lambda (x) (list 'const (car x))) footnote-style-alist)) :group 'footnote) ;;; Style utilities & functions -(defun Footnote-style-p (style) +(defun footnote--style-p (style) "Return non-nil if style is a valid style known to `footnote-mode'." (assq style footnote-style-alist)) -(defun Footnote-index-to-string (index) +(defun footnote--index-to-string (index) "Convert a binary index into a string to display as a footnote. Conversion is done based upon the current selected style." - (let ((alist (if (Footnote-style-p footnote-style) + (let ((alist (if (footnote--style-p footnote-style) (assq footnote-style footnote-style-alist) (nth 0 footnote-style-alist)))) (funcall (nth 1 alist) index))) -(defun Footnote-current-regexp () +(defun footnote--current-regexp () "Return the regexp of the index of the current style." (concat (nth 2 (or (assq footnote-style footnote-style-alist) (nth 0 footnote-style-alist))) "*")) -(defun Footnote-refresh-footnotes (&optional index-regexp) +(defun footnote--refresh-footnotes (&optional index-regexp) "Redraw all footnotes. You must call this or arrange to have this called after changing footnote styles." (unless index-regexp - (setq index-regexp (Footnote-current-regexp))) + (setq index-regexp (footnote--current-regexp))) (save-excursion ;; Take care of the pointers first (let ((i 0) locn alist) @@ -387,7 +485,7 @@ styles." (propertize (concat footnote-start-tag - (Footnote-index-to-string (1+ i)) + (footnote--index-to-string (1+ i)) footnote-end-tag) 'footnote-number (1+ i) footnote-mouse-highlight t) nil "\\1")) @@ -406,13 +504,13 @@ styles." (propertize (concat footnote-start-tag - (Footnote-index-to-string (1+ i)) + (footnote--index-to-string (1+ i)) footnote-end-tag) 'footnote-number (1+ i)) nil "\\1")) (setq i (1+ i)))))) -(defun Footnote-assoc-index (key alist) +(defun footnote--assoc-index (key alist) "Give index of key in alist." (let ((i 0) (max (length alist)) rc) (while (and (null rc) @@ -422,33 +520,33 @@ styles." (setq i (1+ i))) rc)) -(defun Footnote-cycle-style () +(defun footnote-cycle-style () "Select next defined footnote style." (interactive) - (let ((old (Footnote-assoc-index footnote-style footnote-style-alist)) + (let ((old (footnote--assoc-index footnote-style footnote-style-alist)) (max (length footnote-style-alist)) idx) (setq idx (1+ old)) (when (>= idx max) (setq idx 0)) (setq footnote-style (car (nth idx footnote-style-alist))) - (Footnote-refresh-footnotes (nth 2 (nth old footnote-style-alist))))) + (footnote--refresh-footnotes (nth 2 (nth old footnote-style-alist))))) -(defun Footnote-set-style (&optional style) +(defun footnote-set-style (&optional style) "Select a specific style." (interactive (list (intern (completing-read "Footnote Style: " - obarray #'Footnote-style-p 'require-match)))) - (let ((old (Footnote-assoc-index footnote-style footnote-style-alist))) + obarray #'footnote--style-p 'require-match)))) + (let ((old (footnote--assoc-index footnote-style footnote-style-alist))) (setq footnote-style style) - (Footnote-refresh-footnotes (nth 2 (nth old footnote-style-alist))))) + (footnote--refresh-footnotes (nth 2 (nth old footnote-style-alist))))) ;; Internal functions -(defun Footnote-insert-numbered-footnote (arg &optional mousable) +(defun footnote--insert-numbered-footnote (arg &optional mousable) "Insert numbered footnote at (point)." (let ((string (concat footnote-start-tag - (Footnote-index-to-string arg) + (footnote--index-to-string arg) footnote-end-tag))) (insert-before-markers (if mousable @@ -456,7 +554,7 @@ styles." string 'footnote-number arg footnote-mouse-highlight t) (propertize string 'footnote-number arg))))) -(defun Footnote-renumber (from to pointer-alist text-alist) +(defun footnote--renumber (_from to pointer-alist text-alist) "Renumber a single footnote." (let* ((posn-list (cdr pointer-alist))) (setcar pointer-alist to) @@ -464,49 +562,40 @@ styles." (while posn-list (goto-char (car posn-list)) (when (looking-back (concat (regexp-quote footnote-start-tag) - (Footnote-current-regexp) + (footnote--current-regexp) (regexp-quote footnote-end-tag)) (line-beginning-position)) (replace-match (propertize (concat footnote-start-tag - (Footnote-index-to-string to) + (footnote--index-to-string to) footnote-end-tag) 'footnote-number to footnote-mouse-highlight t))) (setq posn-list (cdr posn-list))) (goto-char (cdr text-alist)) (when (looking-at (concat (regexp-quote footnote-start-tag) - (Footnote-current-regexp) + (footnote--current-regexp) (regexp-quote footnote-end-tag))) (replace-match (propertize (concat footnote-start-tag - (Footnote-index-to-string to) + (footnote--index-to-string to) footnote-end-tag) 'footnote-number to))))) -;; Not needed? -(defun Footnote-narrow-to-footnotes () +(defun footnote--narrow-to-footnotes () "Restrict text in buffer to show only text of footnotes." - (interactive) ; testing - (goto-char (point-max)) - (when (re-search-backward footnote-signature-separator nil t) - (let ((end (point))) - (cond - ((and (not (string-equal footnote-section-tag "")) - (re-search-backward - (concat "^" footnote-section-tag-regexp) nil t)) - (narrow-to-region (point) end)) - (footnote-text-marker-alist - (narrow-to-region (cdar footnote-text-marker-alist) end)))))) + (interactive) ; testing + (narrow-to-region (footnote--get-area-point-min) + (footnote--get-area-point-max))) -(defun Footnote-goto-char-point-max () +(defun footnote--goto-char-point-max () "Move to end of buffer or prior to start of .signature." (goto-char (point-max)) (or (re-search-backward footnote-signature-separator nil t) (point))) -(defun Footnote-insert-text-marker (arg locn) +(defun footnote--insert-text-marker (arg locn) "Insert a marker pointing to footnote ARG, at buffer location LOCN." (let ((marker (make-marker))) (unless (assq arg footnote-text-marker-alist) @@ -514,9 +603,9 @@ styles." (setq footnote-text-marker-alist (cons (cons arg marker) footnote-text-marker-alist)) (setq footnote-text-marker-alist - (Footnote-sort footnote-text-marker-alist))))) + (footnote--sort footnote-text-marker-alist))))) -(defun Footnote-insert-pointer-marker (arg locn) +(defun footnote--insert-pointer-marker (arg locn) "Insert a marker pointing to footnote ARG, at buffer location LOCN." (let ((marker (make-marker)) alist) @@ -527,14 +616,14 @@ styles." (setq footnote-pointer-marker-alist (cons (cons arg (list marker)) footnote-pointer-marker-alist)) (setq footnote-pointer-marker-alist - (Footnote-sort footnote-pointer-marker-alist))))) + (footnote--sort footnote-pointer-marker-alist))))) -(defun Footnote-insert-footnote (arg) +(defun footnote--insert-footnote (arg) "Insert a footnote numbered ARG, at (point)." (push-mark) - (Footnote-insert-pointer-marker arg (point)) - (Footnote-insert-numbered-footnote arg t) - (Footnote-goto-char-point-max) + (footnote--insert-pointer-marker arg (point)) + (footnote--insert-numbered-footnote arg t) + (footnote--goto-char-point-max) (if (cond ((not (string-equal footnote-section-tag "")) (re-search-backward (concat "^" footnote-section-tag-regexp) nil t)) @@ -542,8 +631,8 @@ styles." (goto-char (cdar footnote-text-marker-alist)))) (save-restriction (when footnote-narrow-to-footnotes-when-editing - (Footnote-narrow-to-footnotes)) - (Footnote-goto-footnote (1- arg)) ; evil, FIXME (less evil now) + (footnote--narrow-to-footnotes)) + (footnote-goto-footnote (1- arg)) ; evil, FIXME (less evil now) ;; (message "Inserting footnote %d" arg) (unless (or (eq arg 1) @@ -552,11 +641,11 @@ styles." "\n\n" (concat "\n" (regexp-quote footnote-start-tag) - (Footnote-current-regexp) + (footnote--current-regexp) (regexp-quote footnote-end-tag))) nil t) (unless (beginning-of-line) t)) - (Footnote-goto-char-point-max) + (footnote--goto-char-point-max) (cond ((not (string-equal footnote-section-tag "")) (re-search-backward @@ -570,46 +659,115 @@ styles." (unless (string-equal footnote-section-tag "") (insert footnote-section-tag "\n"))) (let ((old-point (point))) - (Footnote-insert-numbered-footnote arg nil) - (Footnote-insert-text-marker arg old-point))) + (footnote--insert-numbered-footnote arg nil) + (footnote--insert-text-marker arg old-point))) -(defun Footnote-sort (list) +(defun footnote--sort (list) (sort list (lambda (e1 e2) (< (car e1) (car e2))))) -(defun Footnote-text-under-cursor () - "Return the number of footnote if in footnote text. +(defun footnote--text-under-cursor () + "Return the number of the current footnote if in footnote text. Return nil if the cursor is not positioned over the text of a footnote." - (when (and (let ((old-point (point))) - (save-excursion - (save-restriction - (Footnote-narrow-to-footnotes) - (and (>= old-point (point-min)) - (<= old-point (point-max)))))) - footnote-text-marker-alist - (>= (point) (cdar footnote-text-marker-alist))) - (let ((i 1) - alist-txt rc) + (when (and footnote-text-marker-alist + (<= (footnote--get-area-point-min) + (point) + (footnote--get-area-point-max))) + (let ((i 1) alist-txt result) (while (and (setq alist-txt (nth i footnote-text-marker-alist)) - (null rc)) - (when (< (point) (cdr alist-txt)) - (setq rc (car (nth (1- i) footnote-text-marker-alist)))) - (setq i (1+ i))) - (when (and (null rc) - (null alist-txt)) - (setq rc (car (nth (1- i) footnote-text-marker-alist)))) - rc))) - -(defun Footnote-under-cursor () + (null result)) + (when (< (point) (cdr alist-txt)) + (setq result (car (nth (1- i) footnote-text-marker-alist)))) + (setq i (1+ i))) + (when (and (null result) (null alist-txt)) + (setq result (car (nth (1- i) footnote-text-marker-alist)))) + result))) + +(defun footnote--under-cursor () "Return the number of the footnote underneath the cursor. Return nil if the cursor is not over a footnote." (or (get-text-property (point) 'footnote-number) - (Footnote-text-under-cursor))) + (footnote--text-under-cursor))) + +(defun footnote--calc-fn-alignment-column () + "Calculate the left alignment for footnote text." + ;; FIXME: Maybe it would be better to go to the footnote's beginning and + ;; see at which column it starts. + (+ footnote-body-tag-spacing + (string-width + (concat footnote-start-tag footnote-end-tag + (footnote--index-to-string + (caar (last footnote-text-marker-alist))))))) + +(defun footnote--fill-prefix-string () + "Return the fill prefix to be used by footnote mode." + ;; TODO: Prefix to this value other prefix strings, such as those + ;; designating a comment line, a message response, or a boxquote. + (make-string (footnote--calc-fn-alignment-column) ?\s)) + +(defun footnote--point-in-body-p () + "Return non-nil if point is in the buffer text area, +i.e. before the beginning of the footnote area." + (< (point) (footnote--get-area-point-min))) + +(defun footnote--get-area-point-min (&optional before-tag) + "Return start of the first footnote. +If there is no footnote area, returns `point-max'. +With optional arg BEFORE-TAG, return position of the `footnote-section-tag' +instead, if applicable." + (cond + ;; FIXME: Shouldn't we use `footnote--get-area-point-max' instead? + ((not footnote-text-marker-alist) (point-max)) + ((not before-tag) (cdr (car footnote-text-marker-alist))) + ((string-equal footnote-section-tag "") + (cdr (car footnote-text-marker-alist))) + (t + (save-excursion + (goto-char (cdr (car footnote-text-marker-alist))) + (if (re-search-backward (concat "^" footnote-section-tag-regexp) nil t) + (match-beginning 0) + (message "Footnote section tag not found!") + ;; This `else' should never happen, and indicates an error, + ;; ie. footnotes already exist and a footnote-section-tag is defined, + ;; but the section tag hasn't been found. We choose to assume that the + ;; user deleted it intentionally and wants us to behave in this buffer + ;; as if the section tag was set "", so we do that, now. + ;;(setq footnote-section-tag "") + ;; + ;; HOWEVER: The rest of footnote mode does not currently honor or + ;; account for this. + ;; + ;; To illustrate the difference in behavior, create a few footnotes, + ;; delete the section tag, and create another footnote. Then undo, + ;; comment the above line (that sets the tag to ""), re-evaluate this + ;; function, and repeat. + ;; + ;; TODO: integrate sanity checks at reasonable operational points. + (cdr (car footnote-text-marker-alist))))))) + +(defun footnote--get-area-point-max () + "Return the end of footnote area. +This is either `point-max' or the start of a `.signature' string, as +defined by variable `footnote-signature-separator'. If there is no +footnote area, returns `point-max'." + (save-excursion (footnote--goto-char-point-max))) + +(defun footnote--adaptive-fill-function (orig-fun) + (or + (and + footnote-mode + footnote-align-to-fn-text + (footnote--text-under-cursor) + ;; (not (footnote--point-in-body-p)) + ;; (< (point) (footnote--signature-area-start-point)) + (footnote--fill-prefix-string)) + ;; If not within a footnote's text, fallback to the default. + (funcall orig-fun))) ;;; User functions -(defun Footnote-make-hole () +(defun footnote--make-hole () (save-excursion (let ((i 0) (notes (length footnote-pointer-marker-alist)) @@ -622,32 +780,32 @@ Return nil if the cursor is not over a footnote." (setq rc (car alist-ptr))) (save-excursion (message "Renumbering from %s to %s" - (Footnote-index-to-string (car alist-ptr)) - (Footnote-index-to-string + (footnote--index-to-string (car alist-ptr)) + (footnote--index-to-string (1+ (car alist-ptr)))) - (Footnote-renumber (car alist-ptr) + (footnote--renumber (car alist-ptr) (1+ (car alist-ptr)) alist-ptr alist-txt))) (setq i (1+ i))) rc))) -(defun Footnote-add-footnote (&optional arg) +(defun footnote-add-footnote () "Add a numbered footnote. The number the footnote receives is dependent upon the relative location of any other previously existing footnotes. If the variable `footnote-narrow-to-footnotes-when-editing' is set, the buffer is narrowed to the footnote body. The restriction is removed -by using `Footnote-back-to-message'." - (interactive "*P") +by using `footnote-back-to-message'." + (interactive "*") (let ((num (if footnote-text-marker-alist (if (< (point) (cl-cadar (last footnote-pointer-marker-alist))) - (Footnote-make-hole) + (footnote--make-hole) (1+ (caar (last footnote-text-marker-alist)))) 1))) (message "Adding footnote %d" num) - (Footnote-insert-footnote num) + (footnote--insert-footnote num) (insert-before-markers (make-string footnote-body-tag-spacing ? )) (let ((opoint (point))) (save-excursion @@ -656,18 +814,18 @@ by using `Footnote-back-to-message'." "\n\n" "\n")) (when footnote-narrow-to-footnotes-when-editing - (Footnote-narrow-to-footnotes))) + (footnote--narrow-to-footnotes))) ;; Emacs/XEmacs bug? save-excursion doesn't restore point when using ;; insert-before-markers. (goto-char opoint)))) -(defun Footnote-delete-footnote (&optional arg) +(defun footnote-delete-footnote (&optional arg) "Delete a numbered footnote. With no parameter, delete the footnote under (point). With ARG specified, delete the footnote with that number." (interactive "*P") (unless arg - (setq arg (Footnote-under-cursor))) + (setq arg (footnote--under-cursor))) (when (and arg (or (not footnote-prompt-before-deletion) (y-or-n-p (format "Really delete footnote %d?" arg)))) @@ -681,7 +839,7 @@ delete the footnote with that number." (save-excursion (goto-char (car locn)) (when (looking-back (concat (regexp-quote footnote-start-tag) - (Footnote-current-regexp) + (footnote--current-regexp) (regexp-quote footnote-end-tag)) (line-beginning-position)) (delete-region (match-beginning 0) (match-end 0)))) @@ -692,20 +850,20 @@ delete the footnote with that number." (point) (if footnote-spaced-footnotes (search-forward "\n\n" nil t) - (save-restriction + (save-restriction ; <= 2017-12 Boruch: WHY?? I see no narrowing / widening here. (end-of-line) (next-single-char-property-change - (point) 'footnote-number nil (Footnote-goto-char-point-max)))))) + (point) 'footnote-number nil (footnote--goto-char-point-max)))))) (setq footnote-pointer-marker-alist (delq alist-ptr footnote-pointer-marker-alist)) (setq footnote-text-marker-alist (delq alist-txt footnote-text-marker-alist)) - (Footnote-renumber-footnotes) + (footnote-renumber-footnotes) (when (and (null footnote-text-marker-alist) (null footnote-pointer-marker-alist)) (save-excursion (if (not (string-equal footnote-section-tag "")) - (let* ((end (Footnote-goto-char-point-max)) + (let* ((end (footnote--goto-char-point-max)) (start (1- (re-search-backward (concat "^" footnote-section-tag-regexp) nil t)))) @@ -715,13 +873,13 @@ delete the footnote with that number." (delete-region start (if (< end (point-max)) end (point-max)))) - (Footnote-goto-char-point-max) + (footnote--goto-char-point-max) (when (looking-back "\n\n" (- (point) 2)) (kill-line -1)))))))) -(defun Footnote-renumber-footnotes (&optional arg) +(defun footnote-renumber-footnotes () "Renumber footnotes, starting from 1." - (interactive "*P") + (interactive "*") (save-excursion (let ((i 0) (notes (length footnote-pointer-marker-alist)) @@ -730,16 +888,16 @@ delete the footnote with that number." (setq alist-ptr (nth i footnote-pointer-marker-alist)) (setq alist-txt (nth i footnote-text-marker-alist)) (unless (= (1+ i) (car alist-ptr)) - (Footnote-renumber (car alist-ptr) (1+ i) alist-ptr alist-txt)) + (footnote--renumber (car alist-ptr) (1+ i) alist-ptr alist-txt)) (setq i (1+ i)))))) -(defun Footnote-goto-footnote (&optional arg) +(defun footnote-goto-footnote (&optional arg) "Jump to the text of a footnote. With no parameter, jump to the text of the footnote under (point). With ARG specified, jump to the text of that footnote." (interactive "P") (unless arg - (setq arg (Footnote-under-cursor))) + (setq arg (footnote--under-cursor))) (let ((footnote (assq arg footnote-text-marker-alist))) (cond (footnote @@ -755,13 +913,13 @@ specified, jump to the text of that footnote." (t (error "I don't see a footnote here"))))) -(defun Footnote-back-to-message (&optional arg) +(defun footnote-back-to-message () "Move cursor back to footnote referent. If the cursor is not over the text of a footnote, point is not changed. If the buffer was narrowed due to `footnote-narrow-to-footnotes-when-editing' being set it is automatically widened." - (interactive "P") - (let ((note (Footnote-text-under-cursor))) + (interactive) + (let ((note (footnote--text-under-cursor))) (when note (when footnote-narrow-to-footnotes-when-editing (widen)) @@ -769,13 +927,13 @@ being set it is automatically widened." (defvar footnote-mode-map (let ((map (make-sparse-keymap))) - (define-key map "a" 'Footnote-add-footnote) - (define-key map "b" 'Footnote-back-to-message) - (define-key map "c" 'Footnote-cycle-style) - (define-key map "d" 'Footnote-delete-footnote) - (define-key map "g" 'Footnote-goto-footnote) - (define-key map "r" 'Footnote-renumber-footnotes) - (define-key map "s" 'Footnote-set-style) + (define-key map "a" 'footnote-add-footnote) + (define-key map "b" 'footnote-back-to-message) + (define-key map "c" 'footnote-cycle-style) + (define-key map "d" 'footnote-delete-footnote) + (define-key map "g" 'footnote-goto-footnote) + (define-key map "r" 'footnote-renumber-footnotes) + (define-key map "s" 'footnote-set-style) map)) (defvar footnote-minor-mode-map @@ -798,8 +956,14 @@ play around with the following keys: :lighter footnote-mode-line-string :keymap footnote-minor-mode-map ;; (filladapt-mode t) + (unless adaptive-fill-function + ;; nil and `ignore' have the same semantics for adaptive-fill-function, + ;; but only `ignore' behaves correctly with add/remove-function. + (setq adaptive-fill-function #'ignore)) + (remove-function (local 'adaptive-fill-function) + #'footnote--adaptive-fill-function) (when footnote-mode - ;; (Footnote-setup-keybindings) + ;; (footnote-setup-keybindings) (make-local-variable 'footnote-style) (make-local-variable 'footnote-body-tag-spacing) (make-local-variable 'footnote-spaced-footnotes) @@ -807,7 +971,12 @@ play around with the following keys: (make-local-variable 'footnote-section-tag-regexp) (make-local-variable 'footnote-start-tag) (make-local-variable 'footnote-end-tag) + (make-local-variable 'adaptive-fill-function) + (add-function :around (local 'adaptive-fill-function) + #'footnote--adaptive-fill-function) + ;; filladapt is an XEmacs package which AFAIK has never been ported + ;; to Emacs. (when (boundp 'filladapt-token-table) ;; add tokens to filladapt to match footnotes ;; 1] xxxxxxxxxxx x x x or [1] x x x x x x x diff --git a/lisp/mail/hashcash.el b/lisp/mail/hashcash.el index aa2e0cb3e74..b5fb1aec00f 100644 --- a/lisp/mail/hashcash.el +++ b/lisp/mail/hashcash.el @@ -1,4 +1,4 @@ -;;; hashcash.el --- Add hashcash payments to email +;;; hashcash.el --- Add hashcash payments to email -*- lexical-binding:t -*- ;; Copyright (C) 2003-2005, 2007-2018 Free Software Foundation, Inc. @@ -47,7 +47,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) ; for case +(eval-when-compile (require 'cl-lib)) (defgroup hashcash nil "Hashcash configuration." @@ -139,12 +139,12 @@ For example, you may want to set this to (\"-Z2\") to reduce header length." (defun hashcash-token-substring () (save-excursion (let ((token "")) - (loop + (cl-loop (setq token (concat token (buffer-substring (point) (hashcash-point-at-eol)))) (goto-char (hashcash-point-at-eol)) (forward-char 1) - (unless (looking-at "[ \t]") (return token)) + (unless (looking-at "[ \t]") (cl-return token)) (while (looking-at "[ \t]") (forward-char 1)))))) (defun hashcash-payment-required (addr) @@ -298,7 +298,7 @@ BUFFER defaults to the current buffer." (let* ((split (split-string token ":")) (key (if (< (hashcash-version token) 1.2) (nth 1 split) - (case (string-to-number (nth 0 split)) + (pcase (string-to-number (nth 0 split)) (0 (nth 2 split)) (1 (nth 3 split)))))) (cond ((null resource) diff --git a/lisp/mail/ietf-drums.el b/lisp/mail/ietf-drums.el index 1b72d39126d..83042b42e87 100644 --- a/lisp/mail/ietf-drums.el +++ b/lisp/mail/ietf-drums.el @@ -1,4 +1,4 @@ -;;; ietf-drums.el --- Functions for parsing RFC822bis headers +;;; ietf-drums.el --- Functions for parsing RFC822bis headers -*- lexical-binding:t -*- ;; Copyright (C) 1998-2018 Free Software Foundation, Inc. @@ -37,7 +37,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defvar ietf-drums-no-ws-ctl-token "\001-\010\013\014\016-\037\177" "US-ASCII control characters excluding CR, LF and white space.") @@ -78,10 +78,10 @@ backslash and doublequote.") (defun ietf-drums-token-to-list (token) "Translate TOKEN into a list of characters." (let ((i 0) - b e c out range) + b c out range) (while (< i (length token)) (setq c (aref token i)) - (incf i) + (cl-incf i) (cond ((eq c ?-) (if b @@ -90,7 +90,7 @@ backslash and doublequote.") (range (while (<= b c) (push (make-char 'ascii b) out) - (incf b)) + (cl-incf b)) (setq range nil)) ((= i (length token)) (push (make-char 'ascii c) out)) @@ -115,7 +115,7 @@ backslash and doublequote.") (setq c (char-after)) (cond ((eq c ?\") - (condition-case err + (condition-case nil (forward-sexp 1) (error (goto-char (point-max))))) ((eq c ?\() diff --git a/lisp/mail/rfc2231.el b/lisp/mail/rfc2231.el index fb03ab4f220..4da3641893b 100644 --- a/lisp/mail/rfc2231.el +++ b/lisp/mail/rfc2231.el @@ -1,4 +1,4 @@ -;;; rfc2231.el --- Functions for decoding rfc2231 headers +;;; rfc2231.el --- Functions for decoding rfc2231 headers -*- lexical-binding:t -*- ;; Copyright (C) 1998-2018 Free Software Foundation, Inc. @@ -22,7 +22,6 @@ ;;; Code: -(eval-when-compile (require 'cl)) (require 'ietf-drums) (require 'rfc2047) (autoload 'mm-encode-body "mm-bodies") @@ -181,7 +180,7 @@ must never cause a Lisp error." ;; Now collect and concatenate continuation parameters. (let ((cparams nil) elem) - (loop for (attribute value part encoded) + (cl-loop for (attribute value part encoded) in (sort parameters (lambda (e1 e2) (< (or (caddr e1) 0) (or (caddr e2) 0)))) @@ -291,7 +290,7 @@ the result of this function." (insert param "*=") (while (not (eobp)) (insert (if (>= num 0) " " "") - param "*" (format "%d" (incf num)) "*=") + param "*" (format "%d" (cl-incf num)) "*=") (forward-line 1)))) (spacep (goto-char (point-min)) diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el index 6b0c93d60cb..7b542638743 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -3399,21 +3399,15 @@ Interactively, empty argument means use same regexp used last time." (defun rmail-simplified-subject (&optional msgnum) "Return the simplified subject of message MSGNUM (or current message). -Simplifying the subject means stripping leading and trailing whitespace, -and typical reply prefixes such as Re:." - (let ((subject (or (rmail-get-header "Subject" msgnum) ""))) +Simplifying the subject means stripping leading and trailing +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]+\\)*")) (setq subject (rfc2047-decode-string subject)) - (if (string-match "\\`[ \t]+" subject) - (setq subject (substring subject (match-end 0)))) - (if (string-match rmail-reply-regexp subject) - (setq subject (substring subject (match-end 0)))) - (if (string-match "[ \t]+\\'" subject) - (setq subject (substring subject 0 (match-beginning 0)))) - ;; If Subject is long, mailers will break it into several lines at - ;; arbitrary places, so normalize whitespace by replacing every - ;; run of whitespace characters with a single space. - (setq subject (replace-regexp-in-string "[ \t\n]+" " " subject)) - subject)) + (setq subject (replace-regexp-in-string regexp "" subject)) + (replace-regexp-in-string "[ \t\n]+" " " subject))) (defun rmail-simplified-subject-regexp () "Return a regular expression matching the current simplified subject. diff --git a/lisp/mail/sendmail.el b/lisp/mail/sendmail.el index b6d0b53ce06..da2d3174ce1 100644 --- a/lisp/mail/sendmail.el +++ b/lisp/mail/sendmail.el @@ -243,15 +243,6 @@ Used by `mail-yank-original' via `mail-indent-citation'." :type 'integer :group 'sendmail) -(defvar mail-yank-hooks nil - "Obsolete hook for modifying a citation just inserted in the mail buffer. -Each hook function can find the citation between (point) and (mark t). -And each hook function should leave point and mark around the citation -text as modified. -This is a normal hook, misnamed for historical reasons. -It is obsolete and mail agents should no longer use it.") -(make-obsolete-variable 'mail-yank-hooks 'mail-citation-hook "19.34") - ;;;###autoload (defcustom mail-citation-hook nil "Hook for modifying a citation just inserted in the mail buffer. @@ -1718,8 +1709,6 @@ and don't delete any header fields." (rfc822-goto-eoh) (point)))))) (run-hooks 'mail-citation-hook))) - (mail-yank-hooks - (run-hooks 'mail-yank-hooks)) (t (mail-indent-citation))))) ;; This is like exchange-point-and-mark, but doesn't activate the mark. @@ -1788,9 +1777,7 @@ and don't delete any header fields." (rfc822-goto-eoh) (point)))))) (run-hooks 'mail-citation-hook)) - (if mail-yank-hooks - (run-hooks 'mail-yank-hooks) - (mail-indent-citation)))))))) + (mail-indent-citation))))))) (defun mail-split-line () "Split current line, moving portion beyond point vertically down. diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el index 571089d2144..20cbeb5f4ea 100644 --- a/lisp/mail/smtpmail.el +++ b/lisp/mail/smtpmail.el @@ -941,7 +941,7 @@ Returns an error if the server cannot be contacted." (if (and (multibyte-string-p data) smtpmail-code-conv-from) - (setq data (string-as-multibyte + (setq data (string-as-multibyte ;FIXME: ??? (encode-coding-string data smtpmail-code-conv-from)))) (if smtpmail-debug-info diff --git a/lisp/mail/uudecode.el b/lisp/mail/uudecode.el index e1ed1c9eb8e..0cdceca6ff5 100644 --- a/lisp/mail/uudecode.el +++ b/lisp/mail/uudecode.el @@ -1,4 +1,4 @@ -;;; uudecode.el -- elisp native uudecode +;;; uudecode.el -- elisp native uudecode -*- lexical-binding:t -*- ;; Copyright (C) 1998-2018 Free Software Foundation, Inc. @@ -24,13 +24,10 @@ ;;; Code: -(eval-when-compile (require 'cl)) - -(eval-and-compile - (defalias 'uudecode-char-int - (if (fboundp 'char-int) - 'char-int - 'identity))) +(defalias 'uudecode-char-int + (if (fboundp 'char-int) + 'char-int + 'identity)) (defgroup uudecode nil "Decoding of uuencoded data." @@ -78,7 +75,7 @@ input and write the converted data to its standard output." If FILE-NAME is non-nil, save the result to FILE-NAME. The program used is specified by `uudecode-decoder-program'." (interactive "r\nP") - (let ((cbuf (current-buffer)) tempfile firstline status) + (let ((cbuf (current-buffer)) tempfile firstline) (save-excursion (goto-char start) (when (re-search-forward uudecode-begin-line nil t) @@ -110,7 +107,7 @@ used is specified by `uudecode-decoder-program'." (insert "begin 600 " (file-name-nondirectory tempfile) "\n") (insert-buffer-substring cbuf firstline end) (cd (file-name-directory tempfile)) - (apply 'call-process-region + (apply #'call-process-region (point-min) (point-max) uudecode-decoder-program @@ -128,20 +125,6 @@ used is specified by `uudecode-decoder-program'." (message "Can not uudecode"))) (ignore-errors (or file-name (delete-file tempfile)))))) -(eval-and-compile - (defalias 'uudecode-string-to-multibyte - (cond - ((featurep 'xemacs) - 'identity) - ((fboundp 'string-to-multibyte) - 'string-to-multibyte) - (t - (lambda (string) - "Return a multibyte string with the same individual chars as string." - (mapconcat - (lambda (ch) (string-as-multibyte (char-to-string ch))) - string "")))))) - ;;;###autoload (defun uudecode-decode-region-internal (start end &optional file-name) "Uudecode region between START and END without using an external program. @@ -216,13 +199,13 @@ If FILE-NAME is non-nil, save the result to FILE-NAME." (if file-name (with-temp-file file-name (unless (featurep 'xemacs) (set-buffer-multibyte nil)) - (insert (apply 'concat (nreverse result)))) + (insert (apply #'concat (nreverse result)))) (or (markerp end) (setq end (set-marker (make-marker) end))) (goto-char start) (if enable-multibyte-characters (dolist (x (nreverse result)) - (insert (uudecode-string-to-multibyte x))) - (insert (apply 'concat (nreverse result)))) + (insert (decode-coding-string x 'binary))) + (insert (apply #'concat (nreverse result)))) (delete-region (point) end)))))) ;;;###autoload diff --git a/lisp/mail/yenc.el b/lisp/mail/yenc.el index 4e3eea729a9..25b4ebb9bda 100644 --- a/lisp/mail/yenc.el +++ b/lisp/mail/yenc.el @@ -1,4 +1,4 @@ -;;; yenc.el --- elisp native yenc decoder +;;; yenc.el --- elisp native yenc decoder -*- lexical-binding:t -*- ;; Copyright (C) 2002-2018 Free Software Foundation, Inc. @@ -32,7 +32,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile (require 'cl-lib)) (defconst yenc-begin-line "^=ybegin.*$") @@ -97,14 +97,14 @@ (cond ((or (eq char ?\r) (eq char ?\n))) ((eq char ?=) - (setq char (char-after (incf first))) + (setq char (char-after (cl-incf first))) (with-current-buffer work-buffer (insert-char (mod (- char 106) 256) 1))) (t (with-current-buffer work-buffer ;;(insert-char (mod (- char 42) 256) 1) (insert-char (aref yenc-decoding-vector char) 1)))) - (incf first)) + (cl-incf first)) (setq bytes (buffer-size work-buffer)) (unless (and (= (cdr (assq 'size header-alist)) bytes) (= (cdr (assq 'size footer-alist)) bytes)) diff --git a/lisp/man.el b/lisp/man.el index c62a61c708d..1a6eda13b7f 100644 --- a/lisp/man.el +++ b/lisp/man.el @@ -1526,16 +1526,16 @@ The following key bindings are currently in effect in the buffer: (set (make-local-variable 'bookmark-make-record-function) 'Man-bookmark-make-record)) -(defsubst Man-build-section-alist () +(defun Man-build-section-list () "Build the list of manpage sections." - (setq Man--sections nil) + (setq Man--sections ()) (goto-char (point-min)) (let ((case-fold-search nil)) - (while (re-search-forward Man-heading-regexp (point-max) t) + (while (re-search-forward Man-heading-regexp nil t) (let ((section (match-string 1))) (unless (member section Man--sections) (push section Man--sections))) - (forward-line 1))) + (forward-line))) (setq Man--sections (nreverse Man--sections))) (defsubst Man-build-references-alist () @@ -1816,7 +1816,7 @@ Specify which REFERENCE to use; default is based on word at point." (widen) (goto-char page-start) (narrow-to-region page-start page-end) - (Man-build-section-alist) + (Man-build-section-list) (Man-build-references-alist) (goto-char (point-min))))) diff --git a/lisp/mh-e/mh-letter.el b/lisp/mh-e/mh-letter.el index 3f88836ddab..71a4623d1f9 100644 --- a/lisp/mh-e/mh-letter.el +++ b/lisp/mh-e/mh-letter.el @@ -60,17 +60,6 @@ (to . mh-alias-letter-expand-alias)) "Alist of header fields and completion functions to use.") -(defvar mh-yank-hooks nil - "Obsolete hook for modifying a citation just inserted in the mail buffer. - -Each hook function can find the citation between point and mark. -And each hook function should leave point and mark around the -citation text as modified. - -This is a normal hook, misnamed for historical reasons. -It is obsolete and is only used if `mail-citation-hook' is nil.") -(mh-make-obsolete-variable 'mh-yank-hooks 'mail-citation-hook "19.34") - ;;; Letter Menu @@ -972,8 +961,6 @@ Otherwise, simply insert MH-INS-STRING before each line." (sc-cite-original)) (mail-citation-hook (run-hooks 'mail-citation-hook)) - (mh-yank-hooks ;old hook name - (run-hooks 'mh-yank-hooks)) (t (or (bolp) (forward-line 1)) (while (< (point) (point-max)) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index e8c6ce6910b..4d14b2641f3 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -1319,7 +1319,7 @@ Repeated uses step through the possible completions." (defvar minibuffer-confirm-exit-commands '(completion-at-point minibuffer-complete minibuffer-complete-word PC-complete PC-complete-word) - "A list of commands which cause an immediately following + "List of commands which cause an immediately following `minibuffer-complete-and-exit' to ask for extra confirmation.") (defun minibuffer-complete-and-exit () @@ -2986,6 +2986,17 @@ or a symbol, see `completion-pcm--merge-completions'." (setq re (replace-match "" t t re 1))) re)) +(defun completion-pcm--pattern-point-idx (pattern) + "Return index of subgroup corresponding to `point' element of PATTERN. +Return nil if there's no such element." + (let ((idx nil) + (i 0)) + (dolist (x pattern) + (unless (stringp x) + (cl-incf i) + (if (eq x 'point) (setq idx i)))) + idx)) + (defun completion-pcm--all-completions (prefix pattern table pred) "Find all completions for PATTERN in TABLE obeying PRED. PATTERN is as returned by `completion-pcm--string->pattern'." @@ -3017,7 +3028,8 @@ PATTERN is as returned by `completion-pcm--string->pattern'." (defun completion-pcm--hilit-commonality (pattern completions) (when completions - (let* ((re (completion-pcm--pattern->regex pattern '(point))) + (let* ((re (completion-pcm--pattern->regex pattern 'group)) + (point-idx (completion-pcm--pattern-point-idx pattern)) (case-fold-search completion-ignore-case)) (mapcar (lambda (str) @@ -3025,8 +3037,16 @@ PATTERN is as returned by `completion-pcm--string->pattern'." (setq str (copy-sequence str)) (unless (string-match re str) (error "Internal error: %s does not match %s" re str)) - (let ((pos (or (match-beginning 1) (match-end 0)))) - (put-text-property 0 pos + (let* ((pos (if point-idx (match-beginning point-idx) (match-end 0))) + (md (match-data)) + (start (pop md)) + (end (pop md))) + (while md + (put-text-property start (pop md) + 'font-lock-face 'completions-common-part + str) + (setq start (pop md))) + (put-text-property start end 'font-lock-face 'completions-common-part str) (if (> (length str) pos) diff --git a/lisp/mpc.el b/lisp/mpc.el index 3941492fa28..81bb5ac35a8 100644 --- a/lisp/mpc.el +++ b/lisp/mpc.el @@ -2403,10 +2403,38 @@ This is used so that they can be compared with `eq', which is needed for (interactive) (mpc-cmd-pause "0")) +(defun mpc-read-seek (prompt) + "Read a seek time. +Returns a string suitable for MPD \"seekcur\" protocol command." + (let* ((str (read-from-minibuffer prompt nil nil nil nil nil t)) + (seconds "\\(?1:[[:digit:]]+\\(?:\\.[[:digit:]]*\\)?\\)") + (minsec (concat "\\(?2:[[:digit:]]+\\):" seconds "?")) + (hrminsec (concat "\\(?3:[[:digit:]]+\\):\\(?:" minsec "?\\|:\\)")) + time sign) + (setq str (string-trim str)) + (when (memq (string-to-char str) '(?+ ?-)) + (setq sign (string (string-to-char str))) + (setq str (substring str 1))) + (setq time + ;; `string-to-number' returns 0 on failure + (cond + ((string-match (concat "^" hrminsec "$") str) + (+ (* 3600 (string-to-number (match-string 3 str))) + (* 60 (string-to-number (or (match-string 2 str) ""))) + (string-to-number (or (match-string 1 str) "")))) + ((string-match (concat "^" minsec "$") str) + (+ (* 60 (string-to-number (match-string 2 str))) + (string-to-number (match-string 1 str)))) + ((string-match (concat "^" seconds "$") str) + (string-to-number (match-string 1 str))) + (t (user-error "Invalid time")))) + (setq time (number-to-string time)) + (if (null sign) time (concat sign time)))) + (defun mpc-seek-current (pos) "Seek within current track." (interactive - (list (read-string "Position to go ([+-]seconds): "))) + (list (mpc-read-seek "Position to go ([+-][[H:]M:]seconds): "))) (mpc-cmd-seekcur pos)) (defun mpc-toggle-play () diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index e62bee4499e..f5a5474e889 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -1,4 +1,4 @@ -;;; ange-ftp.el --- transparent FTP support for GNU Emacs +;;; ange-ftp.el --- transparent FTP support for GNU Emacs -*- lexical-binding:t -*- ;; Copyright (C) 1989-1996, 1998, 2000-2018 Free Software Foundation, ;; Inc. @@ -1168,7 +1168,7 @@ only return the directory part of FILE." (ange-ftp-parse-netrc) (catch 'found-one (maphash - (lambda (host val) + (lambda (host _val) (if (ange-ftp-lookup-passwd host user) (throw 'found-one host))) ange-ftp-user-hashtable) (save-match-data @@ -1399,14 +1399,14 @@ only return the directory part of FILE." (save-match-data (let (res) (maphash - (lambda (key value) + (lambda (key _value) (if (string-match "\\`[^/]*\\(/\\).*\\'" key) (let ((host (substring key 0 (match-beginning 1))) (user (substring key (match-end 1)))) (push (concat user "@" host ":") res)))) ange-ftp-passwd-hashtable) (maphash - (lambda (host user) (push (concat host ":") res)) + (lambda (host _user) (push (concat host ":") res)) ange-ftp-user-hashtable) (or res (list nil))))) @@ -1684,7 +1684,7 @@ good, skip, fatal, or unknown." ange-ftp-process-result ange-ftp-process-result-line))))))) -(defun ange-ftp-process-sentinel (proc str) +(defun ange-ftp-process-sentinel (proc _str) "When FTP process changes state, nuke all file-entries in cache." (let ((name (process-name proc))) (when (string-match "\\*ftp \\([^@]+\\)@\\([^*]+\\)\\*" name) @@ -1733,7 +1733,7 @@ good, skip, fatal, or unknown." (defvar ange-ftp-gwp-running t) (defvar ange-ftp-gwp-status nil) -(defun ange-ftp-gwp-sentinel (proc str) +(defun ange-ftp-gwp-sentinel (_proc _str) (setq ange-ftp-gwp-running nil)) (defun ange-ftp-gwp-filter (proc str) @@ -1873,7 +1873,7 @@ been queued with no result. CONT will still be called, however." (interactive "sHost: ") (if ange-ftp-nslookup-program (let ((default-directory - (if (file-accessible-directory-p default-directory) + (if (ange-ftp-real-file-accessible-directory-p default-directory) default-directory exec-directory)) ;; It would be nice to make process-connection-type nil, @@ -1916,7 +1916,7 @@ on the gateway machine to do the FTP instead." ;; default-directory. (file-name-handler-alist) (default-directory - (if (file-accessible-directory-p default-directory) + (if (ange-ftp-real-file-accessible-directory-p default-directory) default-directory exec-directory)) proc) @@ -3404,6 +3404,10 @@ system TYPE.") file-ent)) (ange-ftp-real-file-directory-p name))) +(defun ange-ftp-file-accessible-directory-p (name) + (and (file-directory-p name) + (file-readable-p name))) + (defun ange-ftp-directory-files (directory &optional full match &rest v19-args) (setq directory (expand-file-name directory)) @@ -3441,9 +3445,9 @@ system TYPE.") (let ((part (ange-ftp-get-file-part file)) (files (ange-ftp-get-files (file-name-directory file)))) (if (ange-ftp-hash-entry-exists-p part files) - (let ((host (nth 0 parsed)) - (user (nth 1 parsed)) - (name (nth 2 parsed)) + (let (;; (host (nth 0 parsed)) + ;; (user (nth 1 parsed)) + ;; (name (nth 2 parsed)) (dirp (gethash part files)) (inode (gethash file ange-ftp-inodes-hashtable))) (unless inode @@ -3829,7 +3833,7 @@ so return the size on the remote host exactly. See RFC 3659." (ange-ftp-call-cont cont result line))) (defun ange-ftp-copy-file (filename newname &optional ok-if-already-exists - keep-date preserve-uid-gid + keep-date _preserve-uid-gid _preserve-selinux-context) (interactive "fCopy file: \nFCopy %s to file: \np") (ange-ftp-copy-file-internal filename @@ -4385,6 +4389,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (put 'directory-files-and-attributes 'ange-ftp 'ange-ftp-directory-files-and-attributes) (put 'file-directory-p 'ange-ftp 'ange-ftp-file-directory-p) +(put 'file-accessible-directory-p 'ange-ftp + 'ange-ftp-file-accessible-directory-p) (put 'file-writable-p 'ange-ftp 'ange-ftp-file-writable-p) (put 'file-readable-p 'ange-ftp 'ange-ftp-file-readable-p) (put 'file-executable-p 'ange-ftp 'ange-ftp-file-executable-p) @@ -4469,6 +4475,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (ange-ftp-run-real-handler 'directory-files-and-attributes args)) (defun ange-ftp-real-file-directory-p (&rest args) (ange-ftp-run-real-handler 'file-directory-p args)) +(defun ange-ftp-real-file-accessible-directory-p (&rest args) + (ange-ftp-run-real-handler 'file-accessible-directory-p args)) (defun ange-ftp-real-file-writable-p (&rest args) (ange-ftp-run-real-handler 'file-writable-p args)) (defun ange-ftp-real-file-readable-p (&rest args) @@ -5199,7 +5207,7 @@ Other orders of $ and _ seem to all work just fine.") ";\\([0-9]+\\)$")) (version 0)) (maphash - (lambda (name val) + (lambda (name _val) (and (string-match regexp name) (setq version (max version diff --git a/lisp/net/mailcap.el b/lisp/net/mailcap.el index 9fbc882fdcc..748fb398933 100644 --- a/lisp/net/mailcap.el +++ b/lisp/net/mailcap.el @@ -1006,6 +1006,14 @@ If FORCE, re-parse even if already parsed." (setq extn (concat "." extn))) (cdr (assoc (downcase extn) mailcap-mime-extensions))) +(defun mailcap-file-name-to-mime-type (file-name) + "Return the MIME content type based on the FILE-NAME's extension. +For instance, \"foo.png\" will result in \"image/png\"." + (mailcap-extension-to-mime + (if (string-match "\\(\\.[^.]+\\)\\'" file-name) + (match-string 1 file-name) + ""))) + (defun mailcap-mime-types () "Return a list of MIME media types." (mailcap-parse-mimetypes) diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el index 71a1e31d73a..520a9e19b42 100644 --- a/lisp/net/newst-backend.el +++ b/lisp/net/newst-backend.el @@ -1,4 +1,4 @@ -;;; newst-backend.el --- Retrieval backend for newsticker. +;;; newst-backend.el --- Retrieval backend for newsticker -*- lexical-binding:t -*- ;; Copyright (C) 2003-2018 Free Software Foundation, Inc. @@ -603,7 +603,7 @@ name/timer pair to `newsticker--retrieval-timer-list'." (cons feed-name timer)))))) ;;;###autoload -(defun newsticker-start (&optional do-not-complain-if-running) +(defun newsticker-start (&optional _do-not-complain-if-running) "Start the newsticker. Start the timers for display and retrieval. If the newsticker, i.e. the timers, are running already a warning message is printed unless @@ -639,9 +639,8 @@ if newsticker has been running." (when (fboundp 'newsticker-stop-ticker) ; silence compiler warnings (newsticker-stop-ticker)) (when (newsticker-running-p) - (mapc (lambda (name-and-timer) - (newsticker--stop-feed (car name-and-timer))) - newsticker--retrieval-timer-list) + (dolist (name-and-timer newsticker--retrieval-timer-list) + (newsticker--stop-feed (car name-and-timer))) (setq newsticker--retrieval-timer-list nil) (run-hooks 'newsticker-stop-hook) (message "Newsticker stopped!"))) @@ -651,9 +650,8 @@ if newsticker has been running." This does NOT start the retrieval timers." (interactive) ;; launch retrieval of news - (mapc (lambda (item) - (newsticker-get-news (car item))) - (append newsticker-url-list-defaults newsticker-url-list))) + (dolist (item (append newsticker-url-list-defaults newsticker-url-list)) + (newsticker-get-news (car item)))) (defun newsticker-save-item (feed item) "Save FEED ITEM." @@ -709,7 +707,7 @@ See `newsticker-get-news'." (let ((buffername (concat " *newsticker-funcall-" feed-name "*"))) (with-current-buffer (get-buffer-create buffername) (erase-buffer) - (insert (string-to-multibyte (funcall function feed-name))) + (newsticker--insert-bytes (funcall function feed-name)) (newsticker--sentinel-work nil t feed-name function (current-buffer))))) @@ -730,10 +728,10 @@ STATUS is the return status as delivered by `url-retrieve', and FEED-NAME is the name of the feed that the news were retrieved from." (let ((buf (get-buffer-create (concat " *newsticker-url-" feed-name "*"))) - (result (string-to-multibyte (buffer-string)))) + (result (buffer-string))) (set-buffer buf) (erase-buffer) - (insert result) + (newsticker--insert-bytes result) ;; remove MIME header (goto-char (point-min)) (search-forward "\n\n" nil t) @@ -1255,9 +1253,6 @@ For the RSS 0.91 specification see URL `http://backend.userland.com/rss091' or URL `http://my.netscape.com/publish/formats/rss-spec-0.91.html'." (newsticker--debug-msg "Parsing RSS 0.91 feed %s" name) (let* ((channelnode (car (xml-get-children topnode 'channel))) - (pub-date (newsticker--decode-rfc822-date - (car (xml-node-children - (car (xml-get-children channelnode 'pubDate)))))) is-new-feed has-new-items) (setq is-new-feed (newsticker--parse-generic-feed name time @@ -1293,7 +1288,7 @@ or URL `http://my.netscape.com/publish/formats/rss-spec-0.91.html'." (car (xml-node-children (car (xml-get-children node 'pubDate)))))) ;; guid-fn - (lambda (node) + (lambda (_node) nil) ;; extra-fn (lambda (node) @@ -1308,9 +1303,6 @@ same as in `newsticker--parse-atom-1.0'. For the RSS 0.92 specification see URL `http://backend.userland.com/rss092'." (newsticker--debug-msg "Parsing RSS 0.92 feed %s" name) (let* ((channelnode (car (xml-get-children topnode 'channel))) - (pub-date (newsticker--decode-rfc822-date - (car (xml-node-children - (car (xml-get-children channelnode 'pubDate)))))) is-new-feed has-new-items) (setq is-new-feed (newsticker--parse-generic-feed name time @@ -1346,7 +1338,7 @@ For the RSS 0.92 specification see URL `http://backend.userland.com/rss092'." (car (xml-node-children (car (xml-get-children node 'pubDate)))))) ;; guid-fn - (lambda (node) + (lambda (_node) nil) ;; extra-fn (lambda (node) @@ -1405,7 +1397,7 @@ For the RSS 1.0 specification see URL `http://web.resource.org/rss/1.0/spec'." (car (xml-node-children (car (xml-get-children node 'date))))))) ;; guid-fn - (lambda (node) + (lambda (_node) nil) ;; extra-fn (lambda (node) @@ -1486,7 +1478,6 @@ The arguments TITLE, DESC, LINK, and EXTRA-ELEMENTS give the feed's title, description, link, and extra elements resp." (let ((title (or title "[untitled]")) (link (or link "")) - (old-item nil) (position 0) (something-was-added nil)) ;; decode numeric entities @@ -1522,89 +1513,89 @@ The arguments TITLE-FN, DESC-FN, LINK-FN, TIME-FN, GUID-FN, and EXTRA-FN give functions for extracting title, description, link, time, guid, and extra-elements resp. They are called with one argument, which is one of the items in ITEMLIST." - (let (title desc link - (old-item nil) - (position 0) + (let ((position 0) (something-was-added nil)) ;; gather all items for this feed - (mapc (lambda (node) - (setq position (1+ position)) - (setq title (or (funcall title-fn node) "[untitled]")) - (setq desc (funcall desc-fn node)) - (setq link (or (funcall link-fn node) "")) - (setq time (or (funcall time-fn node) time)) - ;; It happened that the title or description - ;; contained evil HTML code that confused the - ;; xml parser. Therefore: - (unless (stringp title) - (setq title (prin1-to-string title))) - (unless (or (stringp desc) (not desc)) - (setq desc (prin1-to-string desc))) - ;; ignore items with empty title AND empty desc - (when (or (> (length title) 0) - (> (length desc) 0)) - ;; decode numeric entities - (setq title (xml-substitute-numeric-entities title)) - (when desc - (setq desc (xml-substitute-numeric-entities desc))) - (setq link (xml-substitute-numeric-entities link)) - ;; remove whitespace from title, desc, and link - (setq title (newsticker--remove-whitespace title)) - (setq desc (newsticker--remove-whitespace desc)) - (setq link (newsticker--remove-whitespace link)) - ;; add data to cache - ;; do we have this item already? - (let* ((guid (funcall guid-fn node))) - ;;(message "guid=%s" guid) - (setq old-item - (newsticker--cache-contains newsticker--cache - (intern name) title - desc link nil guid))) - ;; add this item, or mark it as old, or do nothing - (let ((age1 'new) - (age2 'old) - (item-new-p nil)) - (if old-item - (let ((prev-age (newsticker--age old-item))) - (unless newsticker-automatically-mark-items-as-old - ;; Some feeds deliver items multiply, the - ;; first time we find an 'obsolete-old one in - ;; the cache, the following times we find an - ;; 'old one - (if (memq prev-age '(obsolete-old old)) - (setq age2 'old) - (setq age2 'new))) - (if (eq prev-age 'immortal) - (setq age2 'immortal)) - (setq time (newsticker--time old-item))) - ;; item was not there - (setq item-new-p t) - (setq something-was-added t)) - (let ((extra-elements-with-guid (funcall extra-fn node))) - (unless (assoc 'guid extra-elements-with-guid) - (setq extra-elements-with-guid - (cons `(guid nil ,(funcall guid-fn node)) - extra-elements-with-guid))) - (setq newsticker--cache - (newsticker--cache-add - newsticker--cache (intern name) title desc link - time age1 position extra-elements-with-guid - time age2))) - (when item-new-p - (let ((item (newsticker--cache-contains - newsticker--cache (intern name) title - desc link nil))) - (if newsticker-auto-mark-filter-list - (newsticker--run-auto-mark-filter name item)) - (run-hook-with-args - 'newsticker-new-item-functions name item)))))) - itemlist) + (dolist (node itemlist) + (setq position (1+ position)) + (let ((title (or (funcall title-fn node) "[untitled]")) + (desc (funcall desc-fn node)) + (link (or (funcall link-fn node) ""))) + (setq time (or (funcall time-fn node) time)) + ;; It happened that the title or description + ;; contained evil HTML code that confused the + ;; xml parser. Therefore: + (unless (stringp title) + (setq title (prin1-to-string title))) + (unless (or (stringp desc) (not desc)) + (setq desc (prin1-to-string desc))) + ;; ignore items with empty title AND empty desc + (when (or (> (length title) 0) + (> (length desc) 0)) + ;; decode numeric entities + (setq title (xml-substitute-numeric-entities title)) + (when desc + (setq desc (xml-substitute-numeric-entities desc))) + (setq link (xml-substitute-numeric-entities link)) + ;; remove whitespace from title, desc, and link + (setq title (newsticker--remove-whitespace title)) + (setq desc (newsticker--remove-whitespace desc)) + (setq link (newsticker--remove-whitespace link)) + ;; add data to cache + ;; do we have this item already? + (let ((old-item + (let* ((guid (funcall guid-fn node))) + ;;(message "guid=%s" guid) + (newsticker--cache-contains newsticker--cache + (intern name) title + desc link nil guid))) + (age1 'new) + (age2 'old) + (item-new-p nil)) + ;; Add this item, or mark it as old, or do nothing + (if old-item + (let ((prev-age (newsticker--age old-item))) + (unless newsticker-automatically-mark-items-as-old + ;; Some feeds deliver items multiply, the + ;; first time we find an 'obsolete-old one in + ;; the cache, the following times we find an + ;; 'old one + (if (memq prev-age '(obsolete-old old)) + (setq age2 'old) + (setq age2 'new))) + (if (eq prev-age 'immortal) + (setq age2 'immortal)) + (setq time (newsticker--time old-item))) + ;; item was not there + (setq item-new-p t) + (setq something-was-added t)) + (let ((extra-elements-with-guid (funcall extra-fn node))) + (unless (assoc 'guid extra-elements-with-guid) + (setq extra-elements-with-guid + (cons `(guid nil ,(funcall guid-fn node)) + extra-elements-with-guid))) + (setq newsticker--cache + (newsticker--cache-add + newsticker--cache (intern name) title desc link + time age1 position extra-elements-with-guid + time age2))) + (when item-new-p + (let ((item (newsticker--cache-contains + newsticker--cache (intern name) title + desc link nil))) + (if newsticker-auto-mark-filter-list + (newsticker--run-auto-mark-filter name item)) + (run-hook-with-args + 'newsticker-new-item-functions name item))))))) something-was-added)) ;; ====================================================================== ;;; Misc ;; ====================================================================== +(defun newsticker--insert-bytes (bytes) + (insert (decode-coding-string bytes 'binary))) + (defun newsticker--remove-whitespace (string) "Remove leading and trailing whitespace from STRING." ;; we must have ...+ but not ...* in the regexps otherwise xemacs loops @@ -1759,12 +1750,11 @@ Sat, 07 Sep 2002 00:00:01 GMT (setq minute (+ minute offset-minute))))) (condition-case error-data (let ((i 1)) - (mapc (lambda (m) - (if (string= month-name m) - (setq month i)) - (setq i (1+ i))) - '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" - "Sep" "Oct" "Nov" "Dec")) + (dolist (m '("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" + "Sep" "Oct" "Nov" "Dec")) + (if (string= month-name m) + (setq month i)) + (setq i (1+ i))) (encode-time second minute hour day month year t)) (error (message "Cannot decode \"%s\": %s %s" rfc822-string @@ -1775,22 +1765,19 @@ Sat, 07 Sep 2002 00:00:01 GMT (defun newsticker--lists-intersect-p (list1 list2) "Return t if LIST1 and LIST2 share elements." (let ((result nil)) - (mapc (lambda (elt) - (if (memq elt list2) - (setq result t))) - list1) + (dolist (elt list1) + (if (memq elt list2) + (setq result t))) result)) (defun newsticker--update-process-ids () "Update list of ids of active newsticker processes. Checks list of active processes against list of newsticker processes." - (let ((active-procs (process-list)) - (new-list nil)) - (mapc (lambda (proc) - (let ((id (process-id proc))) - (if (memq id newsticker--process-ids) - (setq new-list (cons id new-list))))) - active-procs) + (let ((new-list nil)) + (dolist (proc (process-list)) + (let ((id (process-id proc))) + (if (memq id newsticker--process-ids) + (setq new-list (cons id new-list))))) (setq newsticker--process-ids new-list)) (force-mode-line-update)) @@ -1811,7 +1798,7 @@ If the file does no exist or if it is older than 24 hours download it from URL first." (let ((image-name (concat directory feed-name))) (if (and (file-exists-p image-name) - (time-less-p (current-time) + (time-less-p nil (time-add (nth 5 (file-attributes image-name)) (seconds-to-time 86400)))) (newsticker--debug-msg "%s: Getting image for %s skipped" @@ -1853,7 +1840,7 @@ Save image as FILENAME in DIRECTORY, download it from URL." (process-put proc 'nt-feed-name feed-name) (process-put proc 'nt-filename filename))))) -(defun newsticker--image-sentinel (process event) +(defun newsticker--image-sentinel (process _event) "Sentinel for image-retrieving PROCESS caused by EVENT." (let* ((p-status (process-status process)) (exit-status (process-exit-status process)) @@ -1914,21 +1901,21 @@ from. The image is saved in DIRECTORY as FILENAME." (let ((do-save (or (not status) - (let ((status-type (car status)) - (status-details (cdr status))) - (cond ((eq status-type :redirect) - ;; don't care about redirects - t) - ((eq status-type :error) - ;; silently ignore errors - nil)))))) + ;; (let ((status-type (car status))) + ;; (cond ((eq status-type :redirect) + ;; ;; don't care about redirects + ;; t) + ;; ((eq status-type :error) + ;; ;; silently ignore errors + ;; nil))) + (eq (car status) :redirect)))) (when do-save (let ((buf (get-buffer-create (concat " *newsticker-url-image-" feed-name "-" directory "*"))) - (result (string-to-multibyte (buffer-string)))) + (result (buffer-string))) (set-buffer buf) (erase-buffer) - (insert result) + (newsticker--insert-bytes result) ;; remove MIME header (goto-char (point-min)) (search-forward "\n\n") @@ -2008,7 +1995,7 @@ older than TIME." (when (eq (newsticker--age item) old-age) (let ((exp-time (time-add (newsticker--time item) (seconds-to-time time)))) - (when (time-less-p exp-time (current-time)) + (when (time-less-p exp-time nil) (newsticker--debug-msg "Item `%s' from %s has expired on %s" (newsticker--title item) @@ -2020,7 +2007,7 @@ older than TIME." data) data) -(defun newsticker--cache-contains (data feed title desc link age +(defun newsticker--cache-contains (data feed title desc link _age &optional guid) "Check DATA whether FEED contains an item with the given properties. This function returns the contained item or nil if it is not @@ -2293,9 +2280,8 @@ FEED is a symbol!" (newsticker--cache-read-version1)) (when (y-or-n-p (format "Delete old newsticker cache file? ")) (delete-file newsticker-cache-filename))) - (mapc (lambda (f) - (newsticker--cache-read-feed (car f))) - (append newsticker-url-list-defaults newsticker-url-list)))) + (dolist (f (append newsticker-url-list-defaults newsticker-url-list)) + (newsticker--cache-read-feed (car f))))) (defun newsticker--cache-read-feed (feed-name) "Read cache data for feed named FEED-NAME." @@ -2362,14 +2348,13 @@ Export subscriptions to a buffer in OPML Format." " <ownerName>" (user-full-name) "</ownerName>\n" " </head>\n" " <body>\n")) - (mapc (lambda (sub) - (insert " <outline text=\"") - (insert (newsticker--title sub)) - (insert "\" xmlUrl=\"") - (insert (xml-escape-string (let ((url (cadr sub))) - (if (stringp url) url (prin1-to-string url))))) - (insert "\"/>\n")) - (append newsticker-url-list newsticker-url-list-defaults)) + (dolist (sub (append newsticker-url-list newsticker-url-list-defaults)) + (insert " <outline text=\"") + (insert (newsticker--title sub)) + (insert "\" xmlUrl=\"") + (insert (xml-escape-string (let ((url (cadr sub))) + (if (stringp url) url (prin1-to-string url))))) + (insert "\"/>\n")) (insert " </body>\n</opml>\n")) (pop-to-buffer "*OPML Export*") (when (fboundp 'sgml-mode) @@ -2409,28 +2394,26 @@ removed." This function checks the variable `newsticker-auto-mark-filter-list' for an entry that matches FEED and ITEM." (let ((case-fold-search t)) - (mapc (lambda (filter) - (let ((filter-feed (car filter)) - (pattern-list (cadr filter))) - (when (string-match filter-feed feed) - (newsticker--do-run-auto-mark-filter item pattern-list)))) - newsticker-auto-mark-filter-list))) + (dolist (filter newsticker-auto-mark-filter-list) + (let ((filter-feed (car filter)) + (pattern-list (cadr filter))) + (when (string-match filter-feed feed) + (newsticker--do-run-auto-mark-filter item pattern-list)))))) (defun newsticker--do-run-auto-mark-filter (item list) "Actually compare ITEM against the pattern-LIST. LIST must be an element of `newsticker-auto-mark-filter-list'." - (mapc (lambda (pattern) - (let ((place (nth 1 pattern)) - (regexp (nth 2 pattern)) - (title (newsticker--title item)) - (desc (newsticker--desc item))) - (when (or (eq place 'title) (eq place 'all)) - (when (and title (string-match regexp title)) - (newsticker--process-auto-mark-filter-match item pattern))) - (when (or (eq place 'description) (eq place 'all)) - (when (and desc (string-match regexp desc)) - (newsticker--process-auto-mark-filter-match item pattern))))) - list)) + (dolist (pattern list) + (let ((place (nth 1 pattern)) + (regexp (nth 2 pattern)) + (title (newsticker--title item)) + (desc (newsticker--desc item))) + (when (or (eq place 'title) (eq place 'all)) + (when (and title (string-match regexp title)) + (newsticker--process-auto-mark-filter-match item pattern))) + (when (or (eq place 'description) (eq place 'all)) + (when (and desc (string-match regexp desc)) + (newsticker--process-auto-mark-filter-match item pattern)))))) (defun newsticker--process-auto-mark-filter-match (item pattern) "Process ITEM that matches an auto-mark-filter PATTERN." @@ -2503,7 +2486,7 @@ This function is suited for adding it to `newsticker-new-item-functions'." ;; ====================================================================== ;;; Retrieve samples ;; ====================================================================== -(defun newsticker-retrieve-random-message (feed-name) +(defun newsticker-retrieve-random-message (_feed-name) "Return an artificial RSS string under the name FEED-NAME." (concat "<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?><rss version=\"0.91\">" "<channel>" diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 0395eb4380b..aa71effdd92 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -114,7 +114,7 @@ It is used for TCP/IP devices." (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) (file-acl . ignore) (file-attributes . tramp-adb-handle-file-attributes) - (file-directory-p . tramp-adb-handle-file-directory-p) + (file-directory-p . tramp-handle-file-directory-p) (file-equal-p . tramp-handle-file-equal-p) ;; FIXME: This is too sloppy. (file-executable-p . tramp-handle-file-exists-p) @@ -199,11 +199,13 @@ pass to the OPERATION." (with-temp-buffer ;; `call-process' does not react on timer under MS Windows. ;; That's why we use `start-process'. + ;; We don't know yet whether we need a user or host name for the + ;; connection vector. We assume we don't, it will be OK in most + ;; of the cases. Otherwise, there might be an additional trace + ;; buffer, which doesn't hurt. (let ((p (start-process tramp-adb-program (current-buffer) tramp-adb-program "devices")) - (v (make-tramp-file-name - :method tramp-adb-method :user tramp-current-user - :host tramp-current-host)) + (v (make-tramp-file-name :method tramp-adb-method)) result) (tramp-message v 6 "%s" (mapconcat 'identity (process-command p) " ")) (process-put p 'adjust-window-size-function 'ignore) @@ -245,16 +247,8 @@ pass to the OPERATION." ;; be problems with UNC shares or Cygwin mounts. (let ((default-directory (tramp-compat-temporary-file-directory))) (tramp-make-tramp-file-name - method user domain host port - (tramp-drop-volume-letter - (tramp-run-real-handler - 'expand-file-name (list localname)))))))) - -(defun tramp-adb-handle-file-directory-p (filename) - "Like `file-directory-p' for Tramp files." - (eq (tramp-compat-file-attribute-type - (file-attributes (file-truename filename))) - t)) + v (tramp-drop-volume-letter + (tramp-run-real-handler 'expand-file-name (list localname)))))))) (defun tramp-adb-handle-file-system-info (filename) "Like `file-system-info' for Tramp files." @@ -288,7 +282,7 @@ pass to the OPERATION." "%s%s" (with-parsed-tramp-file-name (expand-file-name filename) nil (tramp-make-tramp-file-name - method user domain host port + v (with-tramp-file-property v localname "file-truename" (let ((result nil)) ; result steps in reverse order (tramp-message v 4 "Finding true name for `%s'" filename) @@ -316,12 +310,10 @@ pass to the OPERATION." (tramp-compat-file-attribute-type (file-attributes (tramp-make-tramp-file-name - method user domain host port - (mapconcat 'identity - (append '("") - (reverse result) - (list thisstep)) - "/"))))) + v (mapconcat 'identity + (append + '("") (reverse result) (list thisstep)) + "/"))))) (cond ((string= "." thisstep) (tramp-message v 5 "Ignoring step `.'")) ((string= ".." thisstep) @@ -549,8 +541,8 @@ Emacs dired can't find files." (let ((par (expand-file-name ".." dir))) (unless (file-directory-p par) (make-directory par parents)))) - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) (unless (or (tramp-adb-send-command-and-check v (format "mkdir %s" (tramp-shell-quote-argument localname))) (and parents (file-directory-p dir))) @@ -560,11 +552,11 @@ Emacs dired can't find files." "Like `delete-directory' for Tramp files." (setq directory (expand-file-name directory)) (with-parsed-tramp-file-name (file-truename directory) nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname)) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname)) (with-parsed-tramp-file-name directory nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) (tramp-adb-barf-unless-okay v (format "%s %s" (if recursive "rm -r" "rmdir") @@ -575,8 +567,8 @@ Emacs dired can't find files." "Like `delete-file' for Tramp files." (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (tramp-adb-barf-unless-okay v (format "rm %s" (tramp-shell-quote-argument localname)) "Couldn't delete %s" filename))) @@ -669,8 +661,8 @@ But handle the case, if the \"test\" command is not available." ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (let* ((curbuf (current-buffer)) (tmpfile (tramp-compat-make-temp-file filename))) (when (and append (file-exists-p filename)) @@ -689,26 +681,35 @@ But handle the case, if the \"test\" command is not available." (tramp-error v 'file-error "Cannot write: `%s'" filename)) (delete-file tmpfile))) - (when (or (eq visit t) (stringp visit)) - (set-visited-file-modtime)) - (unless (equal curbuf (current-buffer)) (tramp-error v 'file-error - "Buffer has changed from `%s' to `%s'" curbuf (current-buffer)))))) + "Buffer has changed from `%s' to `%s'" curbuf (current-buffer))) + + ;; Set file modification time. + (when (or (eq visit t) (stringp visit)) + (set-visited-file-modtime + (tramp-compat-file-attribute-modification-time + (file-attributes filename)))) + + ;; The end. + (when (and (null noninteractive) + (or (eq visit t) (null visit) (stringp visit))) + (tramp-message v 0 "Wrote %s" filename)) + (run-hooks 'tramp-handle-write-region-hook)))) (defun tramp-adb-handle-set-file-modes (filename mode) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (tramp-adb-send-command-and-check v (format "chmod %o %s" mode localname)))) (defun tramp-adb-handle-set-file-times (filename &optional time) "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (let ((time (if (or (null time) (equal time '(0 0))) (current-time) time))) @@ -744,8 +745,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; We must also flush the cache of the directory, ;; because `file-attributes' reads the values from ;; there. - (tramp-flush-file-property v (file-name-directory l2)) - (tramp-flush-file-property v l2) + (tramp-flush-file-properties v (file-name-directory l2)) + (tramp-flush-file-properties v l2) ;; Short track. (tramp-adb-barf-unless-okay v (format @@ -779,8 +780,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; We must also flush the cache of the directory, ;; because `file-attributes' reads the values from ;; there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties + v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (when (tramp-adb-execute-adb-command v "push" (tramp-compat-file-name-unquote filename) @@ -823,10 +825,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (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-property v (file-name-directory l1)) - (tramp-flush-file-property v l1) - (tramp-flush-file-property v (file-name-directory l2)) - (tramp-flush-file-property v l2) + (tramp-flush-file-properties v (file-name-directory l1)) + (tramp-flush-file-properties v l1) + (tramp-flush-file-properties v (file-name-directory l2)) + (tramp-flush-file-properties v l2) ;; Short track. (tramp-adb-barf-unless-okay v (format @@ -861,8 +863,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setq input (with-parsed-tramp-file-name infile nil localname)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) - tmpinput (tramp-make-tramp-file-name - method user domain host port input)) + tmpinput (tramp-make-tramp-file-name v input)) (copy-file infile tmpinput t))) (when input (setq command (format "%s <%s" command input))) @@ -895,8 +896,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; stderr must be copied to remote host. The temporary ;; file must be deleted after execution. (setq stderr (tramp-make-tramp-temp-file v) - tmpstderr (tramp-make-tramp-file-name - method user domain host port stderr)))) + tmpstderr (tramp-make-tramp-file-name v stderr)))) ;; stderr to be discarded. ((null (cadr destination)) (setq stderr "/dev/null")))) @@ -940,7 +940,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when tmpinput (delete-file tmpinput)) (unless process-file-side-effects - (tramp-flush-directory-property v "")) + (tramp-flush-directory-properties v "")) ;; Return exit status. (if (equal ret -1) @@ -1046,7 +1046,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (or (null program) tramp-process-connection-type)) (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) (name1 name) - (i 0)) + (i 0) + ;; We do not want to run timers. + timer-list timer-idle-list) (while (get-process name1) ;; NAME must be unique as process name. @@ -1097,8 +1099,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (set-process-buffer (tramp-get-connection-process v) nil) (kill-buffer (current-buffer))) (set-buffer-modified-p bmp)) - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil)))))) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer")))))) (defun tramp-adb-get-device (vec) "Return full host name from VEC to be used in shell execution. @@ -1107,7 +1109,7 @@ E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" ;; 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-property nil) + (tramp-flush-connection-properties nil) (with-tramp-connection-property (tramp-get-connection-process vec) "device" (let* ((host (tramp-file-name-host vec)) (port (tramp-file-name-port-or-default vec)) @@ -1252,10 +1254,6 @@ connection if a previous connection has died for some reason." (user (tramp-file-name-user vec)) (device (tramp-adb-get-device vec))) - ;; Set variables for proper tracing in `tramp-adb-parse-device-names'. - (setq tramp-current-user (tramp-file-name-user vec) - tramp-current-host (tramp-file-name-host vec)) - ;; Maybe we know already that "su" is not supported. We cannot ;; use a connection property, because we have not checked yet ;; whether it is still the same device. @@ -1324,7 +1322,7 @@ 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-set-file-property vec "" "su-command-p" nil) + (tramp-flush-file-property vec "" "su-command-p") (tramp-error vec 'file-error "Cannot switch to user `%s'" user))) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el new file mode 100644 index 00000000000..45e3bf0a606 --- /dev/null +++ b/lisp/net/tramp-archive.el @@ -0,0 +1,564 @@ +;;; tramp-archive.el --- Tramp archive manager -*- lexical-binding:t -*- + +;; Copyright (C) 2017-2018 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 file archives. This is possible only on +;; machines which have installed the virtual file system for the Gnome +;; Desktop (GVFS). Internally, file archives are mounted via the GVFS +;; "archive" method. + +;; A file archive is a regular file of kind "/path/to/dir/file.EXT". +;; The extension ".EXT" identifies the type of the file archive. A +;; file inside a file archive, called archive file name, has the name +;; "/path/to/dir/file.EXT/dir/file". + +;; Most of the magic file name operations are implemented for archive +;; file names, exceptions are all operations which write into a file +;; archive, and process related operations. Therefore, functions like + +;; (copy-file "/path/to/dir/file.tar/dir/file" "/somewhere/else") + +;; work out of the box. This is also true for file name completion, +;; and for libraries like `dired' or `ediff', which accept archive +;; file names as well. + +;; File archives are identified by the file name extension ".EXT". +;; Since GVFS uses internally the library libarchive(3), all suffixes, +;; which are accepted by this library, work also for archive file +;; names. Accepted suffixes are listed in the constant +;; `tramp-archive-suffixes'. They are + +;; * ".7z" - 7-Zip archives +;; * ".apk" - Android package kits +;; * ".ar" - UNIX archiver formats +;; * ".cab", ".CAB" - Microsoft Windows cabinets +;; * ".cpio" - CPIO archives +;; * ".deb" - Debian packages +;; * ".depot" - HP-UX SD depots +;; * ".exe" - Self extracting Microsoft Windows EXE files +;; * ".iso" - ISO 9660 images +;; * ".jar" - Java archives +;; * ".lzh", "LZH" - Microsoft Windows compressed LHA archives +;; * ".mtree" - BSD mtree format +;; * ".pax" - Posix archives +;; * ".rar" - RAR archives +;; * ".rpm" - Red Hat packages +;; * ".shar" - Shell archives +;; * ".tar", "tbz", "tgz", "tlz", "txz" - (Compressed) tape archives +;; * ".warc" - Web archives +;; * ".xar" - macOS XAR archives +;; * ".xps" - Open XML Paper Specification (OpenXPS) documents +;; * ".zip", ".ZIP" - ZIP archives + +;; File archives could also be compressed, identified by an additional +;; compression suffix. Valid compression suffixes are listed in the +;; constant `tramp-archive-compression-suffixes'. They are ".bz2", +;; ".gz", ".lrz", ".lz", ".lz4", ".lzma", ".lzo", ".uu", ".xz" and +;; ".Z". A valid archive file name would be +;; "/path/to/dir/file.tar.gz/dir/file". Even several suffixes in a +;; row are possible, like "/path/to/dir/file.tar.gz.uu/dir/file". + +;; An archive file name could be a remote file name, as in +;; "/ftp:anonymous@ftp.gnu.org:/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL". +;; Since all file operations are mapped internally to GVFS operations, +;; remote file names supported by tramp-gvfs.el perform better, +;; because no local copy of the file archive must be downloaded first. +;; For example, "/sftp:user@host:..." performs better than the similar +;; "/scp:user@host:...". See the constant +;; `tramp-archive-all-gvfs-methods' for a complete list of +;; tramp-gvfs.el supported method names. + +;; If `url-handler-mode' is enabled, archives could be visited via +;; URLs, like "https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL". +;; This allows complex file operations like + +;; (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" "") + +;; It is even possible to access file archives in file archives, as + +;; (find-file +;; "http://ftp.debian.org/debian/pool/main/c/coreutils/coreutils_8.28-1_amd64.deb/control.tar.gz/control") + +;;; Code: + +(require 'tramp-gvfs) + +(autoload 'dired-uncache "dired") +(autoload 'url-tramp-convert-url-to-tramp "url-tramp") +(defvar url-handler-mode-hook) +(defvar url-handler-regexp) +(defvar url-tramp-protocols) + +;; <https://github.com/libarchive/libarchive/wiki/LibarchiveFormats> +;;;###tramp-autoload +(defconst tramp-archive-suffixes + ;; "cab", "lzh" and "zip" are included with lower and upper letters, + ;; because Microsoft Windows provides them often with capital + ;; letters. + '("7z" ;; 7-Zip archives. + "apk" ;; Android package kits. Not in libarchive testsuite. + "ar" ;; UNIX archiver formats. + "cab" "CAB" ;; Microsoft Windows cabinets. + "cpio" ;; CPIO archives. + "deb" ;; Debian packages. Not in libarchive testsuite. + "depot" ;; HP-UX SD depot. Not in libarchive testsuite. + "exe" ;; Self extracting Microsoft Windows EXE files. + "iso" ;; ISO 9660 images. + "jar" ;; Java archives. Not in libarchive testsuite. + "lzh" "LZH" ;; Microsoft Windows compressed LHA archives. + "mtree" ;; BSD mtree format. + "pax" ;; Posix archives. + "rar" ;; RAR archives. + "rpm" ;; Red Hat packages. + "shar" ;; Shell archives. Not in libarchive testsuite. + "tar" "tbz" "tgz" "tlz" "txz" ;; (Compressed) tape archives. + "warc" ;; Web archives. + "xar" ;; macOS XAR archives. Not in libarchive testsuite. + "xps" ;; Open XML Paper Specification (OpenXPS) documents. + "zip" "ZIP") ;; ZIP archives. + "List of suffixes which indicate a file archive. +It must be supported by libarchive(3).") + +;; <http://unix-memo.readthedocs.io/en/latest/vfs.html> +;; read and write: tar, cpio, pax , gzip , zip, bzip2, xz, lzip, lzma, ar, mtree, iso9660, compress, +;; read only: 7-Zip, mtree, xar, lha/lzh, rar, microsoft cab, + +;;;###tramp-autoload +(defconst tramp-archive-compression-suffixes + '("bz2" "gz" "lrz" "lz" "lz4" "lzma" "lzo" "uu" "xz" "Z") + "List of suffixes which indicate a compressed file. +It must be supported by libarchive(3).") + +;;;###tramp-autoload +(defconst tramp-archive-file-name-regexp + (concat + "\\`" "\\(" ".+" "\\." + ;; Default suffixes ... + (regexp-opt tramp-archive-suffixes) + ;; ... with compression. + "\\(?:" "\\." (regexp-opt tramp-archive-compression-suffixes) "\\)*" + "\\)" ;; \1 + "\\(" "/" ".*" "\\)" "\\'") ;; \2 + "Regular expression matching archive file names.") + +;;;###tramp-autoload +(defconst tramp-archive-method "archive" + "Method name for archives in GVFS.") + +(defconst tramp-archive-all-gvfs-methods + (cons tramp-archive-method + (let ((values (cdr (cadr (get 'tramp-gvfs-methods 'custom-type))))) + (setq values (mapcar 'last values) + values (mapcar 'car values)))) + "List of all methods `tramp-gvfs-methods' offers.") + + +;; New handlers should be added here. +;;;###tramp-autoload +(defconst tramp-archive-file-name-handler-alist + '((access-file . ignore) + (add-name-to-file . tramp-archive-handle-not-implemented) + ;; `byte-compiler-base-file-name' performed by default handler. + ;; `copy-directory' performed by default handler. + (copy-file . tramp-archive-handle-copy-file) + (delete-directory . tramp-archive-handle-not-implemented) + (delete-file . tramp-archive-handle-not-implemented) + ;; `diff-latest-backup-file' performed by default handler. + (directory-file-name . tramp-archive-handle-directory-file-name) + (directory-files . tramp-handle-directory-files) + (directory-files-and-attributes + . tramp-handle-directory-files-and-attributes) + (dired-compress-file . tramp-archive-handle-not-implemented) + (dired-uncache . tramp-archive-handle-dired-uncache) + ;; `expand-file-name' performed by default handler. + (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) + (file-acl . ignore) + (file-attributes . tramp-archive-handle-file-attributes) + (file-directory-p . tramp-handle-file-directory-p) + (file-equal-p . tramp-handle-file-equal-p) + (file-executable-p . tramp-archive-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-archive-handle-file-local-copy) + (file-modes . tramp-handle-file-modes) + (file-name-all-completions . tramp-archive-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 . ignore) + (file-readable-p . tramp-archive-handle-file-readable-p) + (file-regular-p . tramp-handle-file-regular-p) + ;; `file-remote-p' performed by default handler. + (file-selinux-context . tramp-handle-file-selinux-context) + (file-symlink-p . tramp-handle-file-symlink-p) + (file-system-info . tramp-archive-handle-file-system-info) + (file-truename . tramp-archive-handle-file-truename) + (file-writable-p . ignore) + (find-backup-file-name . ignore) + ;; `find-file-noselect' performed by default handler. + ;; `get-file-buffer' performed by default handler. + (insert-directory . tramp-archive-handle-insert-directory) + (insert-file-contents . tramp-archive-handle-insert-file-contents) + (load . tramp-archive-handle-load) + (make-auto-save-file-name . ignore) + (make-directory . tramp-archive-handle-not-implemented) + (make-directory-internal . tramp-archive-handle-not-implemented) + (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) + (make-symbolic-link . tramp-archive-handle-not-implemented) + (process-file . ignore) + (rename-file . tramp-archive-handle-not-implemented) + (set-file-acl . ignore) + (set-file-modes . tramp-archive-handle-not-implemented) + (set-file-selinux-context . ignore) + (set-file-times . tramp-archive-handle-not-implemented) + (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) + (shell-command . tramp-archive-handle-not-implemented) + (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) + (unhandled-file-name-directory . ignore) + (vc-registered . ignore) + (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) + (write-region . tramp-archive-handle-not-implemented)) + "Alist of handler functions for GVFS archive method. +Operations not mentioned here will be handled by the default Emacs primitives.") + +;;;###tramp-autoload +(defun tramp-archive-file-name-handler (operation &rest args) + "Invoke the GVFS archive related OPERATION. +First arg specifies the OPERATION, second arg is a list of arguments to +pass to the OPERATION." + (unless tramp-gvfs-enabled + (tramp-compat-user-error nil "Package `tramp-archive' not supported")) + (let ((tramp-methods (cons `(,tramp-archive-method) tramp-methods)) + (tramp-gvfs-methods tramp-archive-all-gvfs-methods) + (fn (assoc operation tramp-archive-file-name-handler-alist))) + (when (eq (cdr fn) 'tramp-archive-handle-not-implemented) + (setq args (cons operation args))) + (if fn + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args)))) + +;; Mark `operations' the handler is responsible for. +(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'. +(when url-handler-mode (tramp-register-file-name-handlers)) + +(eval-after-load 'url-handler + (progn + (add-hook 'url-handler-mode-hook 'tramp-register-file-name-handlers) + (add-hook + 'tramp-archive-unload-hook + (lambda () + (remove-hook + 'url-handler-mode-hook 'tramp-register-file-name-handlers))))) + +;; Debug. +;(trace-function-background 'tramp-archive-file-name-handler) +;(trace-function-background 'tramp-gvfs-file-name-handler) +;(trace-function-background 'tramp-file-name-archive) +;(trace-function-background 'tramp-archive-dissect-file-name) + + +;; File name conversions. + +(defun tramp-archive-file-name-p (name) + "Return t if NAME is a string with archive file name syntax." + (and (stringp name) + (string-match tramp-archive-file-name-regexp name) + t)) + +(defvar tramp-archive-hash (make-hash-table :test 'equal) + "Hash table for archive local copies.") + +(defun tramp-archive-local-copy (archive) + "Return copy of ARCHIVE, usable by GVFS. +ARCHIVE is the archive component of an archive file name." + (setq archive (file-truename archive)) + (let ((tramp-verbose 0)) + (with-tramp-connection-property + ;; This is just an auxiliary VEC for caching properties. + (make-tramp-file-name :method tramp-archive-method :host archive) + "archive" + (cond + ;; File archives inside file archives. + ((tramp-archive-file-name-p archive) + (let ((archive + (tramp-make-tramp-file-name + (tramp-archive-dissect-file-name archive) nil 'noarchive))) + ;; We call `file-attributes' in order to mount the archive. + (file-attributes archive) + (puthash archive nil tramp-archive-hash) + archive)) + ;; http://... + ((and url-handler-mode + tramp-compat-use-url-tramp-p + (string-match url-handler-regexp archive) + (string-match "https?" (url-type (url-generic-parse-url archive)))) + (let* ((url-tramp-protocols + (cons + (url-type (url-generic-parse-url archive)) + url-tramp-protocols)) + (archive (url-tramp-convert-url-to-tramp archive))) + (puthash archive nil tramp-archive-hash) + archive)) + ;; GVFS supported schemes. + ((or (tramp-gvfs-file-name-p archive) + (not (file-remote-p archive))) + (puthash archive nil tramp-archive-hash) + archive) + ;; Anything else. Here we call `file-local-copy', which we + ;; have avoided so far. + (t (let ((inhibit-file-name-operation 'file-local-copy) + (inhibit-file-name-handlers + (cons 'jka-compr-handler inhibit-file-name-handlers)) + result) + (or (and (setq result (gethash archive tramp-archive-hash nil)) + (file-readable-p result)) + (puthash + archive + (setq result (file-local-copy archive)) + tramp-archive-hash)) + result)))))) + +;;;###tramp-autoload +(defun tramp-archive-cleanup-hash () + "Remove local copies of archives, used by GVFS." + (maphash + (lambda (key value) + ;; Unmount local copy. + (ignore-errors + (let ((tramp-gvfs-methods tramp-archive-all-gvfs-methods) + (file-archive (file-name-as-directory key))) + (tramp-message + (and (tramp-tramp-file-p key) (tramp-dissect-file-name key)) 3 + "Unmounting %s" file-archive) + (tramp-gvfs-unmount + (tramp-dissect-file-name + (tramp-archive-gvfs-file-name file-archive))))) + ;; Delete local copy. + (ignore-errors (when value (delete-file value))) + (remhash key tramp-archive-hash)) + tramp-archive-hash) + (clrhash tramp-archive-hash)) + +(add-hook 'kill-emacs-hook 'tramp-archive-cleanup-hash) +(add-hook 'tramp-archive-unload-hook + (lambda () + (remove-hook 'kill-emacs-hook + 'tramp-archive-cleanup-hash))) + +(defun tramp-archive-dissect-file-name (name) + "Return a `tramp-file-name' structure. +The structure consists of the `tramp-archive-method' method, the +hexlified archive name as host, and the localname. The archive +name is kept in slot `hop'" + (save-match-data + (unless (tramp-archive-file-name-p name) + (tramp-compat-user-error nil "Not an archive file name: \"%s\"" name)) + ;; The `string-match' happened in `tramp-archive-file-name-p'. + (let ((archive (match-string 1 name)) + (localname (match-string 2 name)) + (tramp-verbose 0)) + (make-tramp-file-name + :method tramp-archive-method :user nil :domain nil :host + (url-hexify-string + (tramp-gvfs-url-file-name (tramp-archive-local-copy archive))) + :port nil :localname localname :hop archive)))) + +(defsubst tramp-file-name-archive (vec) + "Extract the archive file name from VEC. +VEC is expected to be a `tramp-file-name', with the method being +`tramp-archive-method', and the host being a coded URL. The +archive name is extracted from the hop part of the VEC structure." + (and (tramp-file-name-p vec) + (string-equal (tramp-file-name-method vec) tramp-archive-method) + (tramp-file-name-hop vec))) + +(defmacro with-parsed-tramp-archive-file-name (filename var &rest body) + "Parse an archive filename and make components available in the body. +This works exactly as `with-parsed-tramp-file-name' for the Tramp +file name structure returned by `tramp-archive-dissect-file-name'. +A variable `foo-archive' (or `archive') will be bound to the +archive name part of FILENAME, assuming `foo' (or nil) is the +value of VAR. OTOH, the variable `foo-hop' (or `hop') won't be +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)))))) + `(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, + ;; and then add here a dummy use of all those variables, so we don't get + ;; flooded by warnings about those vars `body' didn't use. + (ignore ,@(mapcar #'car bindings)) + ,@body))) + +(defun tramp-archive-gvfs-file-name (name) + "Return FILENAME in GVFS syntax." + (tramp-make-tramp-file-name + (tramp-archive-dissect-file-name name) nil 'nohop)) + + +;; File name primitives. + +(defun tramp-archive-handle-copy-file + (filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + "Like `copy-file' for file archives." + (when (tramp-archive-file-name-p newname) + (tramp-error + (tramp-archive-dissect-file-name newname) 'file-error + "Permission denied: %s" newname)) + (copy-file + (tramp-archive-gvfs-file-name filename) newname ok-if-already-exists + keep-date preserve-uid-gid preserve-extended-attributes)) + +(defun tramp-archive-handle-directory-file-name (directory) + "Like `directory-file-name' for file archives." + (with-parsed-tramp-archive-file-name directory nil + (if (and (not (zerop (length localname))) + (eq (aref localname (1- (length localname))) ?/) + (not (string= localname "/"))) + (substring directory 0 -1) + ;; We do not want to leave the file archive. This would require + ;; unnecessary download of http-based file archives, for + ;; example. So we return `directory'. + directory))) + +(defun tramp-archive-handle-dired-uncache (dir) + "Like `dired-uncache' for file archives." + (dired-uncache (tramp-archive-gvfs-file-name dir))) + +(defun tramp-archive-handle-file-attributes (filename &optional id-format) + "Like `file-attributes' for file archives." + (file-attributes (tramp-archive-gvfs-file-name filename) id-format)) + +(defun tramp-archive-handle-file-executable-p (filename) + "Like `file-executable-p' for file archives." + (file-executable-p (tramp-archive-gvfs-file-name filename))) + +(defun tramp-archive-handle-file-local-copy (filename) + "Like `file-local-copy' for file archives." + (file-local-copy (tramp-archive-gvfs-file-name filename))) + +(defun tramp-archive-handle-file-name-all-completions (filename directory) + "Like `file-name-all-completions' for file archives." + (file-name-all-completions filename (tramp-archive-gvfs-file-name directory))) + +(defun tramp-archive-handle-file-readable-p (filename) + "Like `file-readable-p' for file archives." + (with-parsed-tramp-file-name + (tramp-archive-gvfs-file-name filename) nil + (tramp-check-cached-permissions v ?r))) + +(defun tramp-archive-handle-file-system-info (filename) + "Like `file-system-info' for file archives." + (with-parsed-tramp-archive-file-name filename nil + (list (tramp-compat-file-attribute-size (file-attributes archive)) 0 0))) + +(defun tramp-archive-handle-file-truename (filename) + "Like `file-truename' for file archives." + (with-parsed-tramp-archive-file-name filename nil + (let ((local (or (file-symlink-p filename) localname))) + (unless (file-name-absolute-p local) + (setq local (expand-file-name local (file-name-directory localname)))) + (concat (file-truename archive) local)))) + +(defun tramp-archive-handle-insert-directory + (filename switches &optional wildcard full-directory-p) + "Like `insert-directory' for file archives." + (insert-directory + (tramp-archive-gvfs-file-name filename) switches wildcard full-directory-p) + (goto-char (point-min)) + (while (search-forward (tramp-archive-gvfs-file-name filename) nil 'noerror) + (replace-match filename))) + +(defun tramp-archive-handle-insert-file-contents + (filename &optional visit beg end replace) + "Like `insert-file-contents' for file archives." + (let ((result + (insert-file-contents + (tramp-archive-gvfs-file-name filename) visit beg end replace))) + (prog1 + (list (expand-file-name filename) + (cadr result)) + (when visit (setq buffer-file-name filename))))) + +(defun tramp-archive-handle-load + (file &optional noerror nomessage nosuffix must-suffix) + "Like `load' for file archives." + (load + (tramp-archive-gvfs-file-name file) noerror nomessage nosuffix must-suffix)) + +(defun tramp-archive-handle-temporary-file-directory () + "Like `temporary-file-directory' for file archives." + ;; If the default directory, the file archive, is located on a + ;; mounted directory, it is returned as it. Not what we want. + (with-parsed-tramp-archive-file-name default-directory nil + (let ((default-directory (file-name-directory archive))) + (tramp-compat-temporary-file-directory)))) + +(defun tramp-archive-handle-not-implemented (operation &rest args) + "Generic handler for operations not implemented for file archives." + (let ((v (ignore-errors + (tramp-archive-dissect-file-name + (apply 'tramp-file-name-for-operation operation args))))) + (tramp-message v 10 "%s" (cons operation args)) + (tramp-error + v 'file-error + "Operation `%s' not implemented for file archives" operation))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-archive 'force))) + +(provide 'tramp-archive) + +;;; TODO: + +;; * See, whether we could retrieve better file attributes like uid, +;; gid, permissions. +;; +;; * Implement write access, when possible. + +;;; tramp-archive.el ends here diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index b95d2935926..97c687598f2 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -98,10 +98,7 @@ matching entries of `tramp-connection-properties'." (dolist (elt tramp-connection-properties) (when (string-match (or (nth 0 elt) "") - (tramp-make-tramp-file-name - (tramp-file-name-method key) (tramp-file-name-user key) - (tramp-file-name-domain key) (tramp-file-name-host key) - (tramp-file-name-port key) nil)) + (tramp-make-tramp-file-name key 'noloc 'nohop)) (tramp-set-connection-property key (nth 1 elt) (nth 2 elt))))) hash))) @@ -117,8 +114,7 @@ Returns DEFAULT if not set." (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 + (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) @@ -169,7 +165,22 @@ Returns VALUE." value)) ;;;###tramp-autoload -(defun tramp-flush-file-property (key file) +(defun tramp-flush-file-property (key file property) + "Remove PROPERTY of FILE in the cache context of KEY." + ;; Unify localname. Remove hop from `tramp-file-name' structure. + (setq file (tramp-compat-file-name-unquote file) + key (copy-tramp-file-name key)) + (setf (tramp-file-name-localname key) + (tramp-run-real-handler 'directory-file-name (list file)) + (tramp-file-name-hop key) nil) + (remhash property (tramp-get-hash-table key)) + (tramp-message key 8 "%s %s" file property) + (when (>= tramp-verbose 10) + (let ((var (intern (concat "tramp-cache-set-count-" property)))) + (makunbound var)))) + +;;;###tramp-autoload +(defun tramp-flush-file-properties (key file) "Remove all properties of FILE in the cache context of KEY." (let* ((file (tramp-run-real-handler 'directory-file-name (list file))) @@ -184,10 +195,10 @@ Returns VALUE." ;; Remove file properties of symlinks. (when (and (stringp truename) (not (string-equal file (directory-file-name truename)))) - (tramp-flush-file-property key truename)))) + (tramp-flush-file-properties key truename)))) ;;;###tramp-autoload -(defun tramp-flush-directory-property (key directory) +(defun tramp-flush-directory-properties (key directory) "Remove all properties of DIRECTORY in the cache context of KEY. Remove also properties of all files in subdirectories." (setq directory (tramp-compat-file-name-unquote directory)) @@ -206,7 +217,7 @@ Remove also properties of all files in subdirectories." ;; Remove file properties of symlinks. (when (and (stringp truename) (not (string-equal directory (directory-file-name truename)))) - (tramp-flush-directory-property key truename)))) + (tramp-flush-directory-properties key truename)))) ;; Reverting or killing a buffer should also flush file properties. ;; They could have been changed outside Tramp. In eshell, "ls" would @@ -225,7 +236,7 @@ This is suppressed for temporary buffers." (tramp-verbose 0)) (when (tramp-tramp-file-p bfn) (with-parsed-tramp-file-name bfn nil - (tramp-flush-file-property v localname))))))) + (tramp-flush-file-properties v localname))))))) (add-hook 'before-revert-hook 'tramp-flush-file-function) (add-hook 'eshell-pre-command-hook 'tramp-flush-file-function) @@ -294,7 +305,24 @@ used to cache connection properties of the local machine." (not (eq (tramp-get-connection-property key property 'undef) 'undef))) ;;;###tramp-autoload -(defun tramp-flush-connection-property (key) +(defun tramp-flush-connection-property (key property) + "Remove the named PROPERTY of a connection identified by KEY. +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." + ;; 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)) + (remhash property (tramp-get-hash-table key)) + (setq tramp-cache-data-changed t) + (tramp-message key 7 "%s" property)) + +;;;###tramp-autoload +(defun tramp-flush-connection-properties (key) "Remove all properties identified by KEY. KEY identifies the connection, it is either a process or a `tramp-file-name' structure. A special case is nil, which is @@ -387,6 +415,8 @@ used to cache connection properties of the local machine." (maphash (lambda (key value) (if (and (tramp-file-name-p key) value + (not (string-equal + (tramp-file-name-method key) tramp-archive-method)) (not (tramp-file-name-localname key)) (not (gethash "login-as" value)) (not (gethash "started" value))) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index ef9aca723de..ab3768a91f4 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -49,7 +49,7 @@ SYNTAX can be one of the symbols `default' (default), (unless (string-equal input "") (list (intern input))))) (when syntax - (custom-set-variables `(tramp-syntax ',syntax)))) + (customize-set-variable 'tramp-syntax syntax))) (defun tramp-list-tramp-buffers () "Return a list of all Tramp connection buffers." @@ -80,16 +80,7 @@ When called interactively, a Tramp connection has to be selected." ;; Return nil when there is no Tramp connection. (list (let ((connections - (mapcar - (lambda (x) - (tramp-make-tramp-file-name - (tramp-file-name-method x) - (tramp-file-name-user x) - (tramp-file-name-domain x) - (tramp-file-name-host x) - (tramp-file-name-port x) - (tramp-file-name-localname x))) - (tramp-list-connections))) + (mapcar 'tramp-make-tramp-file-name (tramp-list-connections))) name) (when connections @@ -113,13 +104,13 @@ When called interactively, a Tramp connection has to be selected." (when keep-password (setq tramp-current-connection nil)) ;; Flush file cache. - (tramp-flush-directory-property vec "") + (tramp-flush-directory-properties vec "") ;; Flush connection cache. (when (processp (tramp-get-connection-process vec)) - (tramp-flush-connection-property (tramp-get-connection-process vec)) + (tramp-flush-connection-properties (tramp-get-connection-process vec)) (delete-process (tramp-get-connection-process vec))) - (tramp-flush-connection-property vec) + (tramp-flush-connection-properties vec) ;; Remove buffers. (dolist @@ -152,6 +143,9 @@ This includes password cache, file cache, connection cache, buffers." ;; Flush file and connection cache. (clrhash tramp-cache-data) + ;; Cleanup local copies of archives. + (tramp-archive-cleanup-hash) + ;; Remove buffers. (dolist (name (tramp-list-tramp-buffers)) (when (bufferp (get-buffer name)) (kill-buffer name)))) diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 5bf57638ff8..16b56d74ce5 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -190,11 +190,6 @@ This is a string of ten letters or dashes as in ls -l." (if (get 'file-missing 'error-conditions) 'file-missing 'file-error) "The error symbol for the `file-missing' error.") -(add-hook 'tramp-unload-hook - (lambda () - (unload-feature 'tramp-loaddefs 'force) - (unload-feature 'tramp-compat 'force))) - ;; `file-name-quoted-p', `file-name-quote' and `file-name-unquote' are ;; introduced in Emacs 26. (eval-and-compile @@ -243,6 +238,17 @@ If NAME is a remote file name, the local part of NAME is unquoted." `(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 us `url-tramp-convert-url-to-tramp' prior +;; Emacs 26.1. We use `temporary-file-directory' as indicator. +(defconst tramp-compat-use-url-tramp-p (fboundp 'temporary-file-directory) + "Whether to use url-tramp.el.") + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-loaddefs 'force) + (unload-feature 'tramp-compat 'force))) + (provide 'tramp-compat) ;;; TODO: diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index f370abba319..ffe3bd28bd2 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -49,15 +49,21 @@ ;; The custom option `tramp-gvfs-methods' contains the list of ;; supported connection methods. Per default, these are "afp", "dav", -;; "davs", "gdrive", "obex", "sftp" and "synce". Note that with -;; "obex" it might be necessary to pair with the other bluetooth -;; device, if it hasn't been done already. There might be also some -;; few seconds delay in discovering available bluetooth devices. - -;; Other possible connection methods are "ftp" 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 Tramp -;; implementation. +;; "davs", "gdrive", "obex", "owncloud", "sftp" and "synce". Note +;; that with "obex" it might be necessary to pair with the other +;; bluetooth device, if it hasn't been done already. There might be +;; also some few seconds delay in discovering available bluetooth +;; devices. + +;; "gdrive" and "owncloud" connection methods require a respective +;; account in GNOME Online Accounts, with enabled "Files" service. + +;; 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 +;; Tramp implementation. However, this is not recommended. These +;; methods are listed here for the benefit of file archives, see +;; tramp-archive.el. ;; GVFS offers even more connection methods. The complete list of ;; connection methods of the actual GVFS implementation can be @@ -69,7 +75,7 @@ ;; 'car ;; (dbus-call-method ;; :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker -;; tramp-gvfs-interface-mounttracker "listMountableInfo"))) +;; tramp-gvfs-interface-mounttracker "ListMountableInfo"))) ;; Note that all other connection methods are not tested, beside the ;; ones offered for customization in `tramp-gvfs-methods'. If you @@ -108,9 +114,19 @@ (eval-when-compile (require 'custom)) +;; We don't call `dbus-ping', because this would load dbus.el. +(defconst tramp-gvfs-enabled + (ignore-errors + (and (featurep 'dbusbind) + (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")))) + "Non-nil when GVFS is available.") + ;;;###tramp-autoload (defcustom tramp-gvfs-methods - '("afp" "dav" "davs" "gdrive" "obex" "sftp" "synce") + '("afp" "dav" "davs" "gdrive" "obex" "owncloud" "sftp" "synce") "List of methods for remote files, accessed with GVFS." :group 'tramp :version "26.1" @@ -119,12 +135,24 @@ (const "davs") (const "ftp") (const "gdrive") + (const "http") + (const "https") (const "obex") + (const "owncloud") (const "sftp") (const "smb") (const "synce"))) :require 'tramp) +(defconst tramp-goa-methods '("gdrive" "owncloud") + "List of methods which require registration at GNOME Online Accounts.") + +;; Remove GNOME Online Accounts methods if not supported. +(unless (and tramp-gvfs-enabled + (member tramp-goa-service (dbus-list-known-names :session))) + (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 (when (string-match "\\(.+\\)@\\(\\(?:gmail\\|googlemail\\)\\.com\\)" @@ -158,16 +186,6 @@ (defconst tramp-gvfs-service-daemon "org.gtk.vfs.Daemon" "The well known name of the GVFS daemon.") -;; We don't call `dbus-ping', because this would load dbus.el. -(defconst tramp-gvfs-enabled - (ignore-errors - (and (featurep 'dbusbind) - (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")))) - "Non-nil when GVFS is available.") - (defconst tramp-gvfs-path-mounttracker "/org/gtk/vfs/mounttracker" "The object path of the GVFS daemon.") @@ -289,6 +307,162 @@ It has been changed in GVFS 1.14.") (defconst tramp-gvfs-password-anonymous-supported 16 "Operation supports anonymous users.") +;; For the time being, we just need org.goa.Account and org.goa.Files +;; interfaces. We document the other ones, just in case. + +;;;###tramp-autoload +(defconst tramp-goa-service "org.gnome.OnlineAccounts" + "The well known name of the GNOME Online Accounts service.") + +(defconst tramp-goa-path "/org/gnome/OnlineAccounts" + "The object path of the GNOME Online Accounts.") + +(defconst tramp-goa-path-accounts (concat tramp-goa-path "/Accounts") + "The object path of the GNOME Online Accounts accounts.") + +(defconst tramp-goa-interface-documents "org.gnome.OnlineAccounts.Documents" + "The documents interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Documents'> +;; </interface> + +(defconst tramp-goa-interface-printers "org.gnome.OnlineAccounts.Printers" + "The printers interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Printers'> +;; </interface> + +(defconst tramp-goa-interface-files "org.gnome.OnlineAccounts.Files" + "The files interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Files'> +;; <property type='b' name='AcceptSslErrors' access='read'/> +;; <property type='s' name='Uri' access='read'/> +;; </interface> + +(defconst tramp-goa-interface-contacts "org.gnome.OnlineAccounts.Contacts" + "The contacts interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Contacts'> +;; <property type='b' name='AcceptSslErrors' access='read'/> +;; <property type='s' name='Uri' access='read'/> +;; </interface> + +(defconst tramp-goa-interface-calendar "org.gnome.OnlineAccounts.Calendar" + "The calendar interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Calendar'> +;; <property type='b' name='AcceptSslErrors' access='read'/> +;; <property type='s' name='Uri' access='read'/> +;; </interface> + +(defconst tramp-goa-interface-oauth2based "org.gnome.OnlineAccounts.OAuth2Based" + "The oauth2based interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.OAuth2Based'> +;; <method name='GetAccessToken'> +;; <arg type='s' name='access_token' direction='out'/> +;; <arg type='i' name='expires_in' direction='out'/> +;; </method> +;; <property type='s' name='ClientId' access='read'/> +;; <property type='s' name='ClientSecret' access='read'/> +;; </interface> + +(defconst tramp-goa-interface-account "org.gnome.OnlineAccounts.Account" + "The account interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Account'> +;; <method name='Remove'/> +;; <method name='EnsureCredentials'> +;; <arg type='i' name='expires_in' direction='out'/> +;; </method> +;; <property type='s' name='ProviderType' access='read'/> +;; <property type='s' name='ProviderName' access='read'/> +;; <property type='s' name='ProviderIcon' access='read'/> +;; <property type='s' name='Id' access='read'/> +;; <property type='b' name='IsLocked' access='read'/> +;; <property type='b' name='IsTemporary' access='readwrite'/> +;; <property type='b' name='AttentionNeeded' access='read'/> +;; <property type='s' name='Identity' access='read'/> +;; <property type='s' name='PresentationIdentity' access='read'/> +;; <property type='b' name='MailDisabled' access='readwrite'/> +;; <property type='b' name='CalendarDisabled' access='readwrite'/> +;; <property type='b' name='ContactsDisabled' access='readwrite'/> +;; <property type='b' name='ChatDisabled' access='readwrite'/> +;; <property type='b' name='DocumentsDisabled' access='readwrite'/> +;; <property type='b' name='MapsDisabled' access='readwrite'/> +;; <property type='b' name='MusicDisabled' access='readwrite'/> +;; <property type='b' name='PrintersDisabled' access='readwrite'/> +;; <property type='b' name='PhotosDisabled' access='readwrite'/> +;; <property type='b' name='FilesDisabled' access='readwrite'/> +;; <property type='b' name='TicketingDisabled' access='readwrite'/> +;; <property type='b' name='TodoDisabled' access='readwrite'/> +;; <property type='b' name='ReadLaterDisabled' access='readwrite'/> +;; </interface> + +(defconst tramp-goa-identity-regexp + (concat "^" "\\(" tramp-user-regexp "\\)?" + "@" "\\(" tramp-host-regexp "\\)?" + "\\(?:" ":""\\(" tramp-port-regexp "\\)" "\\)?") + "Regexp matching GNOME Online Accounts \"PresentationIdentity\" property.") + +(defconst tramp-goa-interface-mail "org.gnome.OnlineAccounts.Mail" + "The mail interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Mail'> +;; <property type='s' name='EmailAddress' access='read'/> +;; <property type='s' name='Name' access='read'/> +;; <property type='b' name='ImapSupported' access='read'/> +;; <property type='b' name='ImapAcceptSslErrors' access='read'/> +;; <property type='s' name='ImapHost' access='read'/> +;; <property type='b' name='ImapUseSsl' access='read'/> +;; <property type='b' name='ImapUseTls' access='read'/> +;; <property type='s' name='ImapUserName' access='read'/> +;; <property type='b' name='SmtpSupported' access='read'/> +;; <property type='b' name='SmtpAcceptSslErrors' access='read'/> +;; <property type='s' name='SmtpHost' access='read'/> +;; <property type='b' name='SmtpUseAuth' access='read'/> +;; <property type='b' name='SmtpAuthLogin' access='read'/> +;; <property type='b' name='SmtpAuthPlain' access='read'/> +;; <property type='b' name='SmtpAuthXoauth2' access='read'/> +;; <property type='b' name='SmtpUseSsl' access='read'/> +;; <property type='b' name='SmtpUseTls' access='read'/> +;; <property type='s' name='SmtpUserName' access='read'/> +;; </interface> + +(defconst tramp-goa-interface-chat "org.gnome.OnlineAccounts.Chat" + "The chat interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Chat'> +;; </interface> + +(defconst tramp-goa-interface-photos "org.gnome.OnlineAccounts.Photos" + "The photos interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Photos'> +;; </interface> + +(defconst tramp-goa-path-manager (concat tramp-goa-path "/Manager") + "The object path of the GNOME Online Accounts manager.") + +(defconst tramp-goa-interface-documents "org.gnome.OnlineAccounts.Manager" + "The manager interface of the GNOME Online Accounts.") + +;; <interface name='org.gnome.OnlineAccounts.Manager'> +;; <method name='AddAccount'> +;; <arg type='s' name='provider' direction='in'/> +;; <arg type='s' name='identity' direction='in'/> +;; <arg type='s' name='presentation_identity' direction='in'/> +;; <arg type='a{sv}' name='credentials' direction='in'/> +;; <arg type='a{ss}' name='details' direction='in'/> +;; <arg type='o' name='account_object_path' direction='out'/> +;; </method> +;; </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) + (defconst tramp-bluez-service "org.bluez" "The well known name of the BLUEZ service.") @@ -424,11 +598,13 @@ Every entry is a list (NAME ADDRESS).") ("gvfs-ls" . "list") ("gvfs-mkdir" . "mkdir") ("gvfs-monitor-file" . "monitor") + ("gvfs-mount" . "mount") ("gvfs-move" . "move") ("gvfs-rm" . "remove") ("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" @@ -473,6 +649,13 @@ Every entry is a list (NAME ADDRESS).") ":[[:blank:]]+\\(.*\\)$") "Regexp to parse GVFS file system attributes with `gvfs-info'.") +(defconst tramp-gvfs-owncloud-default-prefix "/remote.php/webdav" + "Default prefix for owncloud / nextcloud methods.") + +(defconst tramp-gvfs-owncloud-default-prefix-regexp + (concat (regexp-quote tramp-gvfs-owncloud-default-prefix) "$") + "Regexp of default prefix for owncloud / nextcloud methods.") + ;; New handlers should be added here. ;;;###tramp-autoload @@ -495,7 +678,7 @@ Every entry is a list (NAME ADDRESS).") (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) (file-acl . ignore) (file-attributes . tramp-gvfs-handle-file-attributes) - (file-directory-p . tramp-gvfs-handle-file-directory-p) + (file-directory-p . tramp-handle-file-directory-p) (file-equal-p . tramp-handle-file-equal-p) (file-executable-p . tramp-gvfs-handle-file-executable-p) (file-exists-p . tramp-handle-file-exists-p) @@ -604,12 +787,24 @@ Return nil for null BYTE-ARRAY." (cond ((and (consp message) (characterp (car message))) (format "%S" (tramp-gvfs-dbus-byte-array-to-string message))) + ((and (consp message) (not (consp (cdr message)))) + (cons (tramp-gvfs-stringify-dbus-message (car message)) + (tramp-gvfs-stringify-dbus-message (cdr message)))) ((consp message) (mapcar 'tramp-gvfs-stringify-dbus-message message)) ((stringp message) (format "%S" message)) (t message))) +(defun tramp-dbus-function (vec func args) + "Apply a D-Bus function FUNC from dbus.el. +The call will be traced by Tramp with trace level 6." + (let (result) + (tramp-message vec 6 "%s" (cons func args)) + (setq result (apply func args)) + (tramp-message vec 6 "%s" result(tramp-gvfs-stringify-dbus-message result)) + result)) + (defmacro with-tramp-dbus-call-method (vec synchronous bus service path interface method &rest args) "Apply a D-Bus call on bus BUS. @@ -618,22 +813,34 @@ If SYNCHRONOUS is non-nil, the call is synchronously. Otherwise, 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'. Additionally, the call -will be traced by Tramp with trace level 6." +or `dbus-call-method-asynchronously'." `(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)))) - result) - (tramp-message ,vec 6 "%s %s" func args) - (setq result (apply func args)) - (tramp-message ,vec 6 "%s" (tramp-gvfs-stringify-dbus-message result)) - result)) + (if ,synchronous (list ,@args) (list 'ignore ,@args))))) + (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 + (vec bus service path interface) + "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. + `(when (member + ,interface + (tramp-dbus-function + ,vec 'dbus-introspect-get-interface-names + (list ,bus ,service ,path))) + (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 "Current Tramp file name to be used, as vector. It is needed when D-Bus signals or errors arrive, because there @@ -642,7 +849,7 @@ is no information where to trace the message.") (defun tramp-gvfs-dbus-event-error (event err) "Called when a D-Bus error message arrives, see `dbus-event-error-functions'." (when tramp-gvfs-dbus-event-vector - (tramp-message tramp-gvfs-dbus-event-vector 10 "%S" event) + (tramp-message tramp-gvfs-dbus-event-vector 6 "%S" event) (tramp-error tramp-gvfs-dbus-event-vector 'file-error "%s" (cadr err)))) ;; `dbus-event-error-hooks' has been renamed to @@ -675,6 +882,7 @@ file names." (unless (memq op '(copy rename)) (error "Unknown operation `%s', must be `copy' or `rename'" op)) + (setq filename (file-truename filename)) (if (file-directory-p filename) (progn (copy-directory filename newname keep-date t) @@ -738,13 +946,13 @@ file names." (when (and t1 (eq op 'rename)) (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname))) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname))) (when t2 (with-parsed-tramp-file-name newname nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname)))))))) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname)))))))) (defun tramp-gvfs-handle-copy-file (filename newname &optional ok-if-already-exists keep-date @@ -778,8 +986,8 @@ file names." (tramp-error v 'file-error "Couldn't delete non-empty %s" directory))) - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) (unless (tramp-gvfs-send-command v (if (and trash delete-by-moving-to-trash) "gvfs-trash" "gvfs-rm") @@ -793,8 +1001,8 @@ file names." (defun tramp-gvfs-handle-delete-file (filename &optional trash) "Like `delete-file' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (unless (tramp-gvfs-send-command v (if (and trash delete-by-moving-to-trash) "gvfs-trash" "gvfs-rm") @@ -1043,11 +1251,6 @@ If FILE-SYSTEM is non-nil, return file system attributes." res-device ))))) -(defun tramp-gvfs-handle-file-directory-p (filename) - "Like `file-directory-p' for Tramp files." - (eq t (tramp-compat-file-attribute-type - (file-attributes (file-truename filename))))) - (defun tramp-gvfs-handle-file-executable-p (filename) "Like `file-executable-p' for Tramp files." (with-parsed-tramp-file-name filename nil @@ -1178,7 +1381,7 @@ file-notify events." (setq filename (directory-file-name (expand-file-name filename))) (with-parsed-tramp-file-name filename nil ;; We don't use cached values. - (tramp-set-file-property v localname "file-system-attributes" 'undef) + (tramp-flush-file-property v localname "file-system-attributes") (let* ((attr (tramp-gvfs-get-root-attributes filename 'file-system)) (size (cdr (assoc "filesystem::size" attr))) (used (cdr (assoc "filesystem::used" attr))) @@ -1203,8 +1406,8 @@ file-notify events." "Like `make-directory' for Tramp files." (setq dir (directory-file-name (expand-file-name dir))) (with-parsed-tramp-file-name dir nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) (save-match-data (let ((ldir (file-name-directory dir))) ;; Make missing directory parts. "gvfs-mkdir -p ..." does not @@ -1260,8 +1463,8 @@ file-notify events." (tramp-error v 'file-error "Couldn't write region to `%s'" filename)))) - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) ;; Set file modification time. (when (or (eq visit t) (stringp visit)) @@ -1270,7 +1473,8 @@ file-notify events." (file-attributes filename)))) ;; The end. - (when (or (eq visit t) (null visit) (stringp visit)) + (when (and (null noninteractive) + (or (eq visit t) (null visit) (stringp visit))) (tramp-message v 0 "Wrote %s" filename)) (run-hooks 'tramp-handle-write-region-hook))) @@ -1290,6 +1494,10 @@ file-notify events." (with-parsed-tramp-file-name filename nil (when (string-equal "gdrive" method) (setq method "google-drive")) + (when (string-equal "owncloud" 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 @@ -1314,24 +1522,6 @@ file-notify events." (dbus-unescape-from-identifier (replace-regexp-in-string "^.*/\\([^/]+\\)$" "\\1" object-path))) -(defun tramp-bluez-address (device) - "Return bluetooth device address from a given bluetooth DEVICE name." - (when (stringp device) - (if (string-match tramp-ipv6-regexp device) - (match-string 0 device) - (cadr (assoc device (tramp-bluez-list-devices)))))) - -(defun tramp-bluez-device (address) - "Return bluetooth device name from a given bluetooth device ADDRESS. -ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." - (when (stringp address) - (while (string-match "[][]" address) - (setq address (replace-match "" t t address))) - (let (result) - (dolist (item (tramp-bluez-list-devices) result) - (when (string-match address (cadr item)) - (setq result (car item))))))) - ;; D-Bus GVFS functions. @@ -1363,13 +1553,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (unless (tramp-get-connection-property l "first-password-request" nil) (tramp-clear-passwd l)) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method l-method - tramp-current-user user - tramp-current-domain l-domain - tramp-current-host l-host - tramp-current-port l-port - password (tramp-read-passwd + (setq password (tramp-read-passwd (tramp-get-connection-process l) pw-prompt)) ;; Return result. @@ -1408,7 +1592,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (tramp-get-connection-process v) message ;; In theory, there can be several choices. ;; Until now, there is only the question whether - ;; to accept an unknown host signature. + ;; to accept an unknown host signature or certificate. (with-temp-buffer ;; Preserve message for `progress-reporter'. (with-temp-message "" @@ -1449,6 +1633,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (while (stringp (car elt)) (setq elt (cdr elt))) (let* ((fuse-mountpoint (tramp-gvfs-dbus-byte-array-to-string (cadr elt))) (mount-spec (cl-caddr elt)) + (prefix (tramp-gvfs-dbus-byte-array-to-string (car mount-spec))) (default-location (tramp-gvfs-dbus-byte-array-to-string (cl-cadddr elt))) (method (tramp-gvfs-dbus-byte-array-to-string @@ -1464,31 +1649,35 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (cadr (assoc "port" (cadr mount-spec))))) (ssl (tramp-gvfs-dbus-byte-array-to-string (cadr (assoc "ssl" (cadr mount-spec))))) - (prefix (concat - (tramp-gvfs-dbus-byte-array-to-string - (car mount-spec)) - (tramp-gvfs-dbus-byte-array-to-string - (or (cadr (assoc "share" (cadr mount-spec))) - (cadr (assoc "volume" (cadr mount-spec)))))))) + (uri (tramp-gvfs-dbus-byte-array-to-string + (cadr (assoc "uri" (cadr mount-spec)))))) (when (string-match "^\\(afp\\|smb\\)" method) (setq method (match-string 1 method))) (when (string-equal "obex" method) (setq host (tramp-bluez-device host))) (when (and (string-equal "dav" method) (string-equal "true" ssl)) (setq method "davs")) + (when (and (string-equal "davs" method) + (string-match + tramp-gvfs-owncloud-default-prefix-regexp prefix)) + (setq method "owncloud")) (when (string-equal "google-drive" method) (setq method "gdrive")) + (when (and (string-equal "http" method) (stringp uri)) + (setq uri (url-generic-parse-url uri) + method (url-type uri) + user (url-user uri) + host (url-host uri) + port (url-portspec uri))) (with-parsed-tramp-file-name (tramp-make-tramp-file-name method user domain host port "") nil (tramp-message v 6 "%s %s" signal-name (tramp-gvfs-stringify-dbus-message mount-info)) - (tramp-set-file-property v "/" "list-mounts" 'undef) + (tramp-flush-file-property v "/" "list-mounts") (if (string-equal (downcase signal-name) "unmounted") - (tramp-flush-file-property v "/") - ;; Set prefix, mountpoint and location. - (unless (string-equal prefix "/") - (tramp-set-file-property v "/" "prefix" prefix)) + (tramp-flush-file-properties v "/") + ;; Set mountpoint and location. (tramp-set-file-property v "/" "fuse-mountpoint" fuse-mountpoint) (tramp-set-connection-property v "default-location" default-location))))))) @@ -1531,6 +1720,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (let* ((fuse-mountpoint (tramp-gvfs-dbus-byte-array-to-string (cadr elt))) (mount-spec (cl-caddr elt)) + (prefix (tramp-gvfs-dbus-byte-array-to-string (car mount-spec))) (default-location (tramp-gvfs-dbus-byte-array-to-string (cl-cadddr elt))) (method (tramp-gvfs-dbus-byte-array-to-string @@ -1546,39 +1736,56 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (cadr (assoc "port" (cadr mount-spec))))) (ssl (tramp-gvfs-dbus-byte-array-to-string (cadr (assoc "ssl" (cadr mount-spec))))) - (prefix (concat - (tramp-gvfs-dbus-byte-array-to-string - (car mount-spec)) - (tramp-gvfs-dbus-byte-array-to-string - (or - (cadr (assoc "share" (cadr mount-spec))) - (cadr (assoc "volume" (cadr mount-spec)))))))) + (uri (tramp-gvfs-dbus-byte-array-to-string + (cadr (assoc "uri" (cadr mount-spec))))) + (share (tramp-gvfs-dbus-byte-array-to-string + (or + (cadr (assoc "share" (cadr mount-spec))) + (cadr (assoc "volume" (cadr mount-spec))))))) (when (string-match "^\\(afp\\|smb\\)" method) (setq method (match-string 1 method))) (when (string-equal "obex" method) (setq host (tramp-bluez-device host))) (when (and (string-equal "dav" method) (string-equal "true" ssl)) (setq method "davs")) + (when (and (string-equal "davs" method) + (string-match + tramp-gvfs-owncloud-default-prefix-regexp prefix)) + (setq method "owncloud")) (when (string-equal "google-drive" method) (setq method "gdrive")) (when (and (string-equal "synce" method) (zerop (length user))) (setq user (or (tramp-file-name-user vec) ""))) + (when (and (string-equal "http" method) (stringp uri)) + (setq uri (url-generic-parse-url uri) + method (url-type uri) + user (url-user uri) + host (url-host uri) + port (url-portspec uri))) (when (and (string-equal method (tramp-file-name-method vec)) (string-equal user (tramp-file-name-user vec)) (string-equal domain (tramp-file-name-domain vec)) (string-equal host (tramp-file-name-host vec)) (string-equal port (tramp-file-name-port vec)) - (string-match (concat "^" (regexp-quote prefix)) + (string-match (concat "^/" (regexp-quote (or share ""))) (tramp-file-name-unquote-localname vec))) - ;; Set prefix, mountpoint and location. - (unless (string-equal prefix "/") - (tramp-set-file-property vec "/" "prefix" prefix)) + ;; Set mountpoint and location. (tramp-set-file-property vec "/" "fuse-mountpoint" fuse-mountpoint) (tramp-set-connection-property vec "default-location" default-location) (throw 'mounted t))))))) +(defun tramp-gvfs-unmount (vec) + "Unmount the object identified by VEC." + (let ((vec (copy-tramp-file-name vec))) + (setf (tramp-file-name-localname vec) "/" + (tramp-file-name-hop vec) nil) + (when (tramp-gvfs-connection-mounted-p vec) + (tramp-gvfs-send-command + vec "gvfs-mount" "-u" + (tramp-gvfs-url-file-name (tramp-make-tramp-file-name vec)))))) + (defun tramp-gvfs-mount-spec-entry (key value) "Construct a mount-spec entry to be used in a mount_spec. It was \"a(say)\", but has changed to \"a{sv})\"." @@ -1597,7 +1804,7 @@ It was \"a(say)\", but has changed to \"a{sv})\"." (localname (tramp-file-name-unquote-localname vec)) (share (when (string-match "^/?\\([^/]+\\)" localname) (match-string 1 localname))) - (ssl (if (string-match "^davs" method) "true" "false")) + (ssl (if (string-match "^davs\\|^owncloud" method) "true" "false")) (mount-spec `(:array ,@(cond @@ -1609,7 +1816,7 @@ It was \"a(say)\", but has changed to \"a{sv})\"." (list (tramp-gvfs-mount-spec-entry "type" method) (tramp-gvfs-mount-spec-entry "host" (concat "[" (tramp-bluez-address host) "]")))) - ((string-match "\\`dav" method) + ((string-match "^dav\\|^owncloud" method) (list (tramp-gvfs-mount-spec-entry "type" "dav") (tramp-gvfs-mount-spec-entry "host" host) (tramp-gvfs-mount-spec-entry "ssl" ssl))) @@ -1620,7 +1827,14 @@ It was \"a(say)\", but has changed to \"a{sv})\"." ((string-equal "gdrive" method) (list (tramp-gvfs-mount-spec-entry "type" "google-drive") (tramp-gvfs-mount-spec-entry "host" host))) - (t + ((string-match "^http" method) + (list (tramp-gvfs-mount-spec-entry "type" "http") + (tramp-gvfs-mount-spec-entry + "uri" + (url-recreate-url + (url-parse-make-urlobj + method user nil host port "/" nil nil t))))) + (t (list (tramp-gvfs-mount-spec-entry "type" method) (tramp-gvfs-mount-spec-entry "host" host)))) ,@(when user @@ -1630,10 +1844,10 @@ It was \"a(say)\", but has changed to \"a{sv})\"." ,@(when port (list (tramp-gvfs-mount-spec-entry "port" port))))) (mount-pref - (if (and (string-match "\\`dav" method) + (if (and (string-match "^dav" method) (string-match "^/?[^/]+" localname)) (match-string 0 localname) - "/"))) + (tramp-gvfs-get-remote-prefix vec)))) ;; Return. `(:struct ,(tramp-gvfs-dbus-string-to-byte-array mount-pref) ,mount-spec))) @@ -1685,6 +1899,21 @@ ID-FORMAT valid values are `string' and `integer'." (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." + (with-tramp-connection-property vec "prefix" + ;; 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 + (make-tramp-goa-name + :method (tramp-file-name-method vec) + :user (tramp-file-name-user vec) + :host (tramp-file-name-host vec) + :port (tramp-file-name-port vec)) + "prefix" "/"))) + (defun tramp-gvfs-maybe-open-connection (vec) "Maybe open a connection VEC. Does not do anything if a connection is already open, but re-opens the @@ -1701,6 +1930,7 @@ connection if a previous connection has died for some reason." :name (tramp-buffer-name vec) :buffer (tramp-get-connection-buffer vec) :server t :host 'local :service t :noquery t))) + (tramp-set-connection-property p "vector" vec) (set-process-query-on-exit-flag p nil))) (unless (tramp-gvfs-connection-mounted-p vec) @@ -1746,7 +1976,8 @@ connection if a previous connection has died for some reason." tramp-gvfs-interface-mountoperation "AskPassword" 'tramp-gvfs-handler-askpassword) - ;; There could be a callback of "askQuestion" when adding fingerprint. + ;; There could be a callback of "askQuestion" when adding + ;; fingerprints or checking certificates. (dbus-register-method :session dbus-service-emacs object-path tramp-gvfs-interface-mountoperation "askQuestion" @@ -1836,11 +2067,84 @@ is applied, and it returns t if the return code is zero." (erase-buffer) (or (zerop (apply 'tramp-call-process vec command nil t nil args)) ;; Remove information about mounted connection. - (and (tramp-flush-file-property vec "/") nil))))) + (and (tramp-flush-file-properties vec "/") nil))))) + + +;; D-Bus GNOME Online Accounts functions. + +(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 +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. +VEC is used only for traces." + (dolist + (object-path + (mapcar + 'car + (tramp-dbus-function + vec 'dbus-get-all-managed-objects + `(:session ,tramp-goa-service ,tramp-goa-path)))) + (let* ((account-properties + (with-tramp-dbus-get-all-properties vec + :session tramp-goa-service object-path + tramp-goa-interface-account)) + (files-properties + (with-tramp-dbus-get-all-properties vec + :session tramp-goa-service object-path + tramp-goa-interface-files)) + (identity + (or (cdr (assoc "PresentationIdentity" account-properties)) "")) + key) + ;; Only accounts which matter. + (when (and + (not (cdr (assoc "FilesDisabled" account-properties))) + (member + (cdr (assoc "ProviderType" account-properties)) + '("google" "owncloud")) + (string-match tramp-goa-identity-regexp identity)) + (setq key (make-tramp-goa-name + :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")) + ;; Cache all properties. + (dolist (prop (nconc account-properties files-properties)) + (tramp-set-connection-property key (car prop) (cdr prop))) + ;; Cache "prefix". + (tramp-message + vec 10 "%s prefix %s" key + (tramp-set-connection-property + key "prefix" + (directory-file-name + (url-filename + (url-generic-parse-url + (tramp-get-connection-property key "Uri" "file:///")))))))))) ;; D-Bus BLUEZ functions. +(defun tramp-bluez-address (device) + "Return bluetooth device address from a given bluetooth DEVICE name." + (when (stringp device) + (if (string-match tramp-ipv6-regexp device) + (match-string 0 device) + (cadr (assoc device (tramp-bluez-list-devices)))))) + +(defun tramp-bluez-device (address) + "Return bluetooth device name from a given bluetooth device ADDRESS. +ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." + (when (stringp address) + (while (string-match "[][]" address) + (setq address (replace-match "" t t address))) + (let (result) + (dolist (item (tramp-bluez-list-devices) result) + (when (string-match address (cadr item)) + (setq result (car item))))))) + (defun tramp-bluez-list-devices () "Return all discovered bluetooth devices as list. Every entry is a list (NAME ADDRESS). @@ -2042,6 +2346,8 @@ They are retrieved from the hal daemon." ;;; TODO: +;; * (Customizable) unmount when exiting Emacs. See tramp-archive.el. + ;; * Host name completion for existing mount points (afp-server, ;; smb-server) or via smb-network. ;; diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 9b74da65805..b7693f8edb5 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1104,8 +1104,8 @@ component is used as the target of the symlink." (tramp-error v 'file-already-exists localname) (delete-file linkname))) - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) ;; Right, they are on the same host, regardless of user, ;; method, etc. We now make the link on the remote @@ -1500,8 +1500,8 @@ of." (defun tramp-sh-handle-set-file-modes (filename mode) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) ;; FIXME: extract the proper text from chmod's stderr. (tramp-barf-unless-okay v @@ -1512,8 +1512,8 @@ of." "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil (when (tramp-get-remote-touch v) - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (let ((time (if (or (null time) (equal time '(0 0))) (current-time) time))) @@ -1605,8 +1605,7 @@ be non-negative integers." (if (and user role type range) (tramp-set-file-property v localname "file-selinux-context" context) - (tramp-set-file-property - v localname "file-selinux-context" 'undef)) + (tramp-flush-file-property v localname "file-selinux-context")) t))))) (defun tramp-remote-acl-p (vec) @@ -1646,7 +1645,7 @@ be non-negative integers." (tramp-set-file-property v localname "file-acl" acl-string) t) ;; In case of errors, we return nil. - (tramp-set-file-property v localname "file-acl-string" 'undef) + (tramp-flush-file-property v localname "file-acl-string") nil))) ;; Simple functions using the `test' command. @@ -1940,8 +1939,8 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" v2-localname))))) (tramp-error v2 'file-already-exists newname) (delete-file newname))) - (tramp-flush-file-property v2 (file-name-directory v2-localname)) - (tramp-flush-file-property v2 v2-localname) + (tramp-flush-file-properties v2 (file-name-directory v2-localname)) + (tramp-flush-file-properties v2 v2-localname) (tramp-barf-unless-okay v1 (format "%s %s %s" ln @@ -2007,8 +2006,8 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" ;; When newname did exist, we have wrong cached values. (when t2 (with-parsed-tramp-file-name newname nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname)))))) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname)))))) (defun tramp-sh-handle-rename-file (filename newname &optional ok-if-already-exists) @@ -2133,14 +2132,16 @@ file names." ;; In case of `rename', we must flush the cache of the source file. (when (and t1 (eq op 'rename)) (with-parsed-tramp-file-name filename v1 - (tramp-flush-file-property v1 (file-name-directory v1-localname)) - (tramp-flush-file-property v1 v1-localname))) + (tramp-flush-file-properties + v1 (file-name-directory v1-localname)) + (tramp-flush-file-properties v1 v1-localname))) ;; When newname did exist, we have wrong cached values. (when t2 (with-parsed-tramp-file-name newname v2 - (tramp-flush-file-property v2 (file-name-directory v2-localname)) - (tramp-flush-file-property v2 v2-localname)))))))) + (tramp-flush-file-properties + v2 (file-name-directory v2-localname)) + (tramp-flush-file-properties v2 v2-localname)))))))) (defun tramp-do-copy-or-rename-file-via-buffer (op filename newname keep-date) "Use an Emacs buffer to copy or rename a file. @@ -2362,15 +2363,6 @@ The method used must be an out-of-band method." (expand-file-name ".." tmpfile) 'recursive) (delete-file tmpfile))))) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method (tramp-file-name-method v) - tramp-current-user (or (tramp-file-name-user v) - (tramp-get-connection-property - v "login-as" nil)) - tramp-current-domain (tramp-file-name-domain v) - tramp-current-host (tramp-file-name-host v) - tramp-current-port (tramp-file-name-port v)) - ;; Check which ones of source and target are Tramp files. (setq source (funcall (if (and (file-directory-p filename) @@ -2481,7 +2473,9 @@ The method used must be an out-of-band method." ;; The default directory must be remote. (let ((default-directory (file-name-directory (if t1 filename newname))) - (process-environment (copy-sequence process-environment))) + (process-environment (copy-sequence process-environment)) + ;; We do not want to run timers. + timer-list timer-idle-list) ;; Set the transfer process properties. (tramp-set-connection-property v "process-name" (buffer-name (current-buffer))) @@ -2524,8 +2518,8 @@ The method used must be an out-of-band method." p v nil tramp-actions-copy-out-of-band)))) ;; Reset the transfer process properties. - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") ;; Clear the remote prompt. (when (and remote-copy-program (not (tramp-send-command-and-check v nil))) @@ -2556,7 +2550,7 @@ The method used must be an out-of-band method." "Like `make-directory' for Tramp files." (setq dir (expand-file-name dir)) (with-parsed-tramp-file-name dir nil - (tramp-flush-directory-property v (file-name-directory localname)) + (tramp-flush-directory-properties v (file-name-directory localname)) (save-excursion (tramp-barf-unless-okay v (format "%s %s" @@ -2568,8 +2562,8 @@ The method used must be an out-of-band method." "Like `delete-directory' for Tramp files." (setq directory (expand-file-name directory)) (with-parsed-tramp-file-name directory nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) (tramp-barf-unless-okay v (format "cd / && %s %s" (or (and trash (tramp-get-remote-trash v)) @@ -2581,8 +2575,8 @@ The method used must be an out-of-band method." "Like `delete-file' for Tramp files." (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (tramp-barf-unless-okay v (format "%s %s" (or (and trash (tramp-get-remote-trash v)) "rm -f") @@ -2595,7 +2589,7 @@ The method used must be an out-of-band method." "Like `dired-compress-file' for Tramp files." ;; Code stolen mainly from dired-aux.el. (with-parsed-tramp-file-name file nil - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v localname) (save-excursion (let ((suffixes dired-compress-file-suffixes) suffix) @@ -2831,8 +2825,8 @@ the result will be a local, non-Tramp, file name." (let ((vec (tramp-get-connection-property proc "vector" nil))) (when vec (tramp-message vec 5 "Sentinel called: `%S' `%s'" proc event) - (tramp-flush-connection-property proc) - (tramp-flush-directory-property vec ""))))) + (tramp-flush-connection-properties proc) + (tramp-flush-directory-properties vec ""))))) ;; We use BUFFER also as connection buffer during setup. Because of ;; this, its original contents must be saved, and restored once @@ -2866,13 +2860,7 @@ the result will be a local, non-Tramp, file name." ;; We discard hops, if existing, that's why we cannot use ;; `file-remote-p'. (prompt (format "PS1=%s %s" - (tramp-make-tramp-file-name - (tramp-file-name-method v) - (tramp-file-name-user v) - (tramp-file-name-domain v) - (tramp-file-name-host v) - (tramp-file-name-port v) - (tramp-file-name-localname v)) + (tramp-make-tramp-file-name v nil 'nohop) tramp-initial-end-of-output)) ;; We use as environment the difference to toplevel ;; `process-environment'. @@ -2908,7 +2896,9 @@ the result will be a local, non-Tramp, file name." ;; We do not want to raise an error when ;; `start-file-process' has been started several times in ;; `eshell' and friends. - (tramp-current-connection nil) + tramp-current-connection + ;; We do not want to run timers. + timer-list timer-idle-list p) (while (get-process name1) @@ -2972,8 +2962,8 @@ the result will be a local, non-Tramp, file name." (set-process-buffer p nil) (kill-buffer (current-buffer))) (set-buffer-modified-p bmp)) - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil)))))) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer")))))) (defun tramp-sh-handle-process-file (program &optional infile destination display &rest args) @@ -3095,7 +3085,7 @@ the result will be a local, non-Tramp, file name." (when tmpinput (delete-file tmpinput)) (unless process-file-side-effects - (tramp-flush-directory-property v "")) + (tramp-flush-directory-properties v "")) ;; Return exit status. (if (equal ret -1) @@ -3399,8 +3389,8 @@ the result will be a local, non-Tramp, file name." (when coding-system-used (set 'last-coding-system-used coding-system-used)))) - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) ;; We must protect `last-coding-system-used', now we have set it ;; to its correct value. @@ -3420,7 +3410,8 @@ the result will be a local, non-Tramp, file name." ;; Set the ownership. (when need-chown (tramp-set-file-uid-gid filename uid gid)) - (when (or (eq visit t) (null visit) (stringp visit)) + (when (and (null noninteractive) + (or (eq visit t) (null visit) (stringp visit))) (tramp-message v 0 "Wrote %s" filename)) (run-hooks 'tramp-handle-write-region-hook))))) @@ -4727,7 +4718,8 @@ connection if a previous connection has died for some reason." (setenv "PS1" tramp-initial-end-of-output) (unless (stringp tramp-encoding-shell) (tramp-error vec 'file-error "`tramp-encoding-shell' not set")) - (let* ((target-alist (tramp-compute-multi-hops vec)) + (let* ((current-host (system-name)) + (target-alist (tramp-compute-multi-hops vec)) ;; We will apply `tramp-ssh-controlmaster-options' ;; only for the first hop. (options (tramp-ssh-controlmaster-options vec)) @@ -4750,13 +4742,12 @@ connection if a previous connection has died for some reason." tramp-encoding-command-interactive) (list tramp-encoding-shell)))))) - ;; Set sentinel and query flag. + ;; Set sentinel and query flag. Initialize variables. (tramp-set-connection-property p "vector" vec) (set-process-sentinel p 'tramp-process-sentinel) (process-put p 'adjust-window-size-function 'ignore) (set-process-query-on-exit-flag p nil) - (setq tramp-current-connection (cons vec (current-time)) - tramp-current-host (system-name)) + (setq tramp-current-connection (cons vec (current-time))) (tramp-message vec 6 "%s" (mapconcat 'identity (process-command p) " ")) @@ -4810,16 +4801,16 @@ connection if a previous connection has died for some reason." ;; Check, whether there is a restricted shell. (dolist (elt tramp-restricted-shell-hosts-alist) - (when (string-match elt tramp-current-host) + (when (string-match elt current-host) (setq r-shell t))) + (setq current-host l-host) - ;; Set variables for computing the prompt for - ;; reading password. - (setq tramp-current-method l-method - tramp-current-user l-user - tramp-current-domain l-domain - tramp-current-host l-host - tramp-current-port l-port) + ;; Set password prompt vector. + (tramp-set-connection-property + p "password-vector" + (make-tramp-file-name + :method l-method :user l-user :domain l-domain + :host l-host :port l-port)) ;; Add login environment. (when login-env @@ -5244,14 +5235,7 @@ Nonexistent directories are removed from spec." (lambda (x) (and (stringp x) - (file-directory-p - (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - (tramp-file-name-host vec) - (tramp-file-name-port vec) - x)) + (file-directory-p (tramp-make-tramp-file-name vec x)) x)) remote-path))))) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 59db6ee6071..c8697285360 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -228,10 +228,10 @@ See `tramp-actions-before-shell' for more info.") (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (expand-file-name . tramp-smb-handle-expand-file-name) - (file-accessible-directory-p . tramp-smb-handle-file-directory-p) + (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) (file-acl . tramp-smb-handle-file-acl) (file-attributes . tramp-smb-handle-file-attributes) - (file-directory-p . tramp-smb-handle-file-directory-p) + (file-directory-p . tramp-handle-file-directory-p) (file-file-equal-p . tramp-handle-file-equal-p) (file-executable-p . tramp-handle-file-exists-p) (file-exists-p . tramp-handle-file-exists-p) @@ -370,8 +370,8 @@ pass to the OPERATION." (delete-file newname))) ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v2 (file-name-directory v2-localname)) - (tramp-flush-file-property v2 v2-localname) + (tramp-flush-file-properties v2 (file-name-directory v2-localname)) + (tramp-flush-file-properties v2 v2-localname) (unless (tramp-smb-send-command v1 @@ -449,13 +449,6 @@ pass to the OPERATION." (if (not (file-directory-p newname)) (make-directory newname parents)) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method method - tramp-current-user user - tramp-current-domain domain - tramp-current-host host - tramp-current-port port) - (let* ((share (tramp-smb-get-share v)) (localname (file-name-as-directory (replace-regexp-in-string @@ -464,7 +457,9 @@ pass to the OPERATION." (expand-file-name tramp-temp-name-prefix (tramp-compat-temporary-file-directory)))) - (args (list (concat "//" host "/" share) "-E"))) + (args (list (concat "//" host "/" share) "-E")) + ;; We do not want to run timers. + timer-list timer-idle-list) (if (not (zerop (length user))) (setq args (append args (list "-U" user))) @@ -534,8 +529,8 @@ pass to the OPERATION." (tramp-message v 6 "\n%s" (buffer-string)))) ;; Reset the transfer process properties. - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") (when t1 (delete-directory tmpdir 'recursive)))) ;; Handle KEEP-DATE argument. @@ -552,8 +547,8 @@ pass to the OPERATION." ;; When newname did exist, we have wrong cached values. (when t2 (with-parsed-tramp-file-name newname nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname)))) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname)))) ;; We must do it file-wise. (t @@ -598,8 +593,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (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)) @@ -633,8 +628,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (with-parsed-tramp-file-name directory nil ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-directory-properties v localname) (unless (tramp-smb-send-command v (format "%s \"%s\"" @@ -654,8 +649,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (with-parsed-tramp-file-name filename nil ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (unless (tramp-smb-send-command v (format "%s \"%s\"" @@ -739,62 +734,58 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (defun tramp-smb-handle-file-acl (filename) "Like `file-acl' for Tramp files." - (with-parsed-tramp-file-name filename nil - (with-tramp-file-property v localname "file-acl" - (when (executable-find tramp-smb-acl-program) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method method - tramp-current-user user - tramp-current-domain domain - tramp-current-host host - tramp-current-port port) - - (let* ((share (tramp-smb-get-share v)) - (localname (replace-regexp-in-string - "\\\\" "/" (tramp-smb-get-localname v))) - (args (list (concat "//" host "/" share) "-E"))) - - (if (not (zerop (length user))) - (setq args (append args (list "-U" user))) - (setq args (append args (list "-N")))) - - (when domain (setq args (append args (list "-W" domain)))) - (when port (setq args (append args (list "-p" port)))) - (when tramp-smb-conf - (setq args (append args (list "-s" tramp-smb-conf)))) - (setq - args - (append args (list (tramp-unquote-shell-quote-argument localname) - "2>/dev/null"))) - - (unwind-protect - (with-temp-buffer - ;; Set the transfer process properties. - (tramp-set-connection-property - v "process-name" (buffer-name (current-buffer))) - (tramp-set-connection-property - v "process-buffer" (current-buffer)) - - ;; Use an asynchronous processes. By this, password - ;; can be handled. - (let ((p (apply - 'start-process - (tramp-get-connection-name v) - (tramp-get-connection-buffer v) - tramp-smb-acl-program args))) - - (tramp-message - v 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-set-connection-property p "vector" v) - (process-put p 'adjust-window-size-function 'ignore) - (set-process-query-on-exit-flag p nil) - (tramp-process-actions p v nil tramp-smb-actions-get-acl) - (when (> (point-max) (point-min)) - (substring-no-properties (buffer-string))))) - - ;; Reset the transfer process properties. - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil))))))) + (ignore-errors + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property v localname "file-acl" + (when (executable-find tramp-smb-acl-program) + (let* ((share (tramp-smb-get-share v)) + (localname (replace-regexp-in-string + "\\\\" "/" (tramp-smb-get-localname v))) + (args (list (concat "//" host "/" share) "-E")) + ;; We do not want to run timers. + timer-list timer-idle-list) + + (if (not (zerop (length user))) + (setq args (append args (list "-U" user))) + (setq args (append args (list "-N")))) + + (when domain (setq args (append args (list "-W" domain)))) + (when port (setq args (append args (list "-p" port)))) + (when tramp-smb-conf + (setq args (append args (list "-s" tramp-smb-conf)))) + (setq + args + (append args (list (tramp-unquote-shell-quote-argument localname) + "2>/dev/null"))) + + (unwind-protect + (with-temp-buffer + ;; Set the transfer process properties. + (tramp-set-connection-property + v "process-name" (buffer-name (current-buffer))) + (tramp-set-connection-property + v "process-buffer" (current-buffer)) + + ;; Use an asynchronous process. By this, password can + ;; be handled. + (let ((p (apply + 'start-process + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + tramp-smb-acl-program args))) + + (tramp-message + v 6 "%s" (mapconcat 'identity (process-command p) " ")) + (tramp-set-connection-property p "vector" v) + (process-put p 'adjust-window-size-function 'ignore) + (set-process-query-on-exit-flag p nil) + (tramp-process-actions p v nil tramp-smb-actions-get-acl) + (when (> (point-max) (point-min)) + (substring-no-properties (buffer-string))))) + + ;; Reset the transfer process properties. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer")))))))) (defun tramp-smb-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." @@ -911,13 +902,6 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (list id link uid gid atime mtime ctime size mode nil inode (tramp-get-device vec)))))))) -(defun tramp-smb-handle-file-directory-p (filename) - "Like `file-directory-p' for Tramp files." - (and (file-exists-p filename) - (eq ?d - (aref (tramp-compat-file-attribute-modes (file-attributes filename)) - 0)))) - (defun tramp-smb-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name (file-truename filename) nil @@ -1164,8 +1148,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (format "mkdir \"%s\"" file))) ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname)) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname)) (unless (file-directory-p directory) (tramp-error v 'file-error "Couldn't make directory %s" directory)))))) @@ -1211,8 +1195,8 @@ component is used as the target of the symlink." ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (unless (tramp-smb-send-command @@ -1222,7 +1206,7 @@ component is used as the target of the symlink." (tramp-error v 'file-error "error with make-symbolic-link, see buffer `%s' for details" - (buffer-name))))))) + (tramp-get-connection-buffer v))))))) (defun tramp-smb-handle-process-file (program &optional infile destination display &rest args) @@ -1235,6 +1219,8 @@ component is used as the target of the symlink." (let* ((name (file-name-nondirectory program)) (name1 name) (i 0) + ;; We do not want to run timers. + timer-list timer-idle-list input tmpinput outbuf command ret) ;; Determine input. @@ -1327,14 +1313,14 @@ component is used as the target of the symlink." ;; Cleanup. We remove all file cache values for the connection, ;; because the remote process could have changed them. - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") (when tmpinput (delete-file tmpinput)) (unless outbuf (kill-buffer (tramp-get-connection-property v "process-buffer" nil))) (unless process-file-side-effects - (tramp-flush-directory-property v "")) + (tramp-flush-directory-properties v "")) ;; Return exit status. (if (equal ret -1) @@ -1370,10 +1356,10 @@ component is used as the target of the symlink." ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v1 (file-name-directory v1-localname)) - (tramp-flush-file-property v1 v1-localname) - (tramp-flush-file-property v2 (file-name-directory v2-localname)) - (tramp-flush-file-property v2 v2-localname) + (tramp-flush-file-properties v1 (file-name-directory v1-localname)) + (tramp-flush-file-properties v1 v1-localname) + (tramp-flush-file-properties v2 (file-name-directory v2-localname)) + (tramp-flush-file-properties v2 v2-localname) (unless (tramp-smb-get-share v2) (tramp-error v2 'file-error "Target `%s' must contain a share name" newname)) @@ -1403,21 +1389,17 @@ component is used as the target of the symlink." "Like `set-file-acl' for Tramp files." (ignore-errors (with-parsed-tramp-file-name filename nil - (when (and (stringp acl-string) (executable-find tramp-smb-acl-program)) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method method - tramp-current-user user - tramp-current-domain domain - tramp-current-host host - tramp-current-port port) - (tramp-set-file-property v localname "file-acl" 'undef) + (tramp-flush-file-property v localname "file-acl") + (when (and (stringp acl-string) (executable-find tramp-smb-acl-program)) (let* ((share (tramp-smb-get-share v)) (localname (replace-regexp-in-string "\\\\" "/" (tramp-smb-get-localname v))) (args (list (concat "//" host "/" share) "-E" "-S" (replace-regexp-in-string - "\n" "," acl-string)))) + "\n" "," acl-string))) + ;; We do not want to run timers. + timer-list timer-idle-list) (if (not (zerop (length user))) (setq args (append args (list "-U" user))) @@ -1470,14 +1452,14 @@ component is used as the target of the symlink." t))) ;; Reset the transfer process properties. - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil))))))) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer"))))))) (defun tramp-smb-handle-set-file-modes (filename mode) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil (when (tramp-smb-get-cifs-capabilities v) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v localname) (unless (tramp-smb-send-command v (format "chmod \"%s\" %o" (tramp-smb-get-localname v) mode)) (tramp-error @@ -1497,7 +1479,9 @@ component is used as the target of the symlink." (command (mapconcat 'identity (cons program args) " ")) (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) (name1 name) - (i 0)) + (i 0) + ;; We do not want to run timers. + timer-list timer-idle-list) (unwind-protect (save-excursion (save-restriction @@ -1530,8 +1514,8 @@ component is used as the target of the symlink." (set-process-buffer (tramp-get-connection-process v) nil) (kill-buffer (current-buffer))) (set-buffer-modified-p bmp))) - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil))))) + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer"))))) (defun tramp-smb-handle-substitute-in-file-name (filename) "Like `handle-substitute-in-file-name' for Tramp files. @@ -1564,8 +1548,8 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (let ((curbuf (current-buffer)) (tmpfile (tramp-compat-make-temp-file filename))) (when (and append (file-exists-p filename)) @@ -1589,9 +1573,18 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (tramp-error v 'file-error "Buffer has changed from `%s' to `%s'" curbuf (current-buffer))) - (when (eq visit t) - (set-visited-file-modtime))))) + ;; Set file modification time. + (when (or (eq visit t) (stringp visit)) + (set-visited-file-modtime + (tramp-compat-file-attribute-modification-time + (file-attributes filename)))) + + ;; The end. + (when (and (null noninteractive) + (or (eq visit t) (null visit) (stringp visit))) + (tramp-message v 0 "Wrote %s" filename)) + (run-hooks 'tramp-handle-write-region-hook)))) ;; Internal file name functions. @@ -1889,8 +1882,8 @@ If ARGUMENT is non-nil, use it as argument for tramp-smb-version (tramp-get-connection-property vec "smbclient-version" tramp-smb-version)) - (tramp-flush-directory-property vec "") - (tramp-flush-connection-property vec)) + (tramp-flush-directory-properties vec "") + (tramp-flush-connection-properties vec)) (tramp-set-connection-property vec "smbclient-version" tramp-smb-version))) @@ -1971,13 +1964,6 @@ If ARGUMENT is non-nil, use it as argument for (process-put p 'adjust-window-size-function 'ignore) (set-process-query-on-exit-flag p nil) - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method tramp-smb-method - tramp-current-user user - tramp-current-domain domain - tramp-current-host host - tramp-current-port port) - (condition-case err (let (tramp-message-show-message) ;; Play login scenario. @@ -1998,8 +1984,8 @@ If ARGUMENT is non-nil, use it as argument for smbserver-version (tramp-get-connection-property vec "smbserver-version" smbserver-version)) - (tramp-flush-directory-property vec "") - (tramp-flush-connection-property vec)) + (tramp-flush-directory-properties vec "") + (tramp-flush-connection-properties vec)) (tramp-set-connection-property vec "smbserver-version" smbserver-version)))) diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index c4839e7f697..72321dbdeba 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1182,21 +1182,6 @@ means to use always cached values for the directory contents." ;;; Internal Variables: -(defvar tramp-current-method nil - "Connection method for this *tramp* buffer.") - -(defvar tramp-current-user nil - "Remote login name for this *tramp* buffer.") - -(defvar tramp-current-domain nil - "Remote domain name for this *tramp* buffer.") - -(defvar tramp-current-host nil - "Remote host for this *tramp* buffer.") - -(defvar tramp-current-port nil - "Remote port for this *tramp* buffer.") - (defvar tramp-current-connection nil "Last connection timestamp.") @@ -1390,7 +1375,7 @@ values." (make-tramp-file-name :method method :user user :domain domain :host host :port port - :localname (or localname "") :hop hop))))) + :localname localname :hop hop))))) (defun tramp-buffer-name (vec) "A name for the connection buffer VEC." @@ -1401,30 +1386,65 @@ values." (format "*tramp/%s %s@%s*" method user-domain host-port) (format "*tramp/%s %s*" method host-port)))) -(defun tramp-make-tramp-file-name - (method user domain host port localname &optional hop) - "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME. -When not nil, optional DOMAIN, PORT and HOP are used." - (concat tramp-prefix-format hop - (unless (or (zerop (length method)) - (zerop (length tramp-postfix-method-format))) - (concat method tramp-postfix-method-format)) - user - (unless (zerop (length domain)) - (concat tramp-prefix-domain-format domain)) - (unless (zerop (length user)) - tramp-postfix-user-format) - (when host - (if (string-match tramp-ipv6-regexp host) - (concat tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) - host)) - (unless (zerop (length port)) - (concat tramp-prefix-port-format port)) - tramp-postfix-host-format - (when localname localname))) +(defun tramp-make-tramp-file-name (&rest args) + "Construct a Tramp file name from ARGS. + +ARGS could have two different signatures. The first one is of +type (VEC &optional LOCALNAME HOP). +If LOCALNAME is nil, the value in VEC is used. If it is a +symbol, a null localname will be used. Otherwise, LOCALNAME is +expected to be a string, which will be used. +If HOP is nil, the value in VEC is used. If it is a symbol, a +null hop will be used. Otherwise, HOP is expected to be a +string, which will be used. + +The other signature exists for backward compatibility. It has +the form (METHOD USER DOMAIN HOST PORT LOCALNAME &optional HOP)." + (let (method user domain host port localname hop) + (cond + ((tramp-file-name-p (car args)) + (setq method (tramp-file-name-method (car args)) + user (tramp-file-name-user (car args)) + domain (tramp-file-name-domain (car args)) + host (tramp-file-name-host (car args)) + port (tramp-file-name-port (car args)) + localname (tramp-file-name-localname (car args)) + hop (tramp-file-name-hop (car args))) + (when (cadr args) + (setq localname (and (stringp (cadr args)) (cadr args)))) + (when (cl-caddr args) + (setq hop (and (stringp (cl-caddr args)) (cl-caddr args))))) + + (t (setq method (nth 0 args) + user (nth 1 args) + domain (nth 2 args) + host (nth 3 args) + port (nth 4 args) + localname (nth 5 args) + hop (nth 6 args)))) + + (when (zerop (length method)) + (signal 'wrong-type-argument (list 'stringp method))) + (concat tramp-prefix-format hop + (unless (zerop (length tramp-postfix-method-format)) + (concat method tramp-postfix-method-format)) + user + (unless (zerop (length domain)) + (concat tramp-prefix-domain-format domain)) + (unless (zerop (length user)) + tramp-postfix-user-format) + (when host + (if (string-match tramp-ipv6-regexp host) + (concat + tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) + host)) + (unless (zerop (length port)) + (concat tramp-prefix-port-format port)) + tramp-postfix-host-format + localname))) (defun tramp-completion-make-tramp-file-name (method user host localname) - "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME. + "Construct a Tramp file name from METHOD, USER, HOST and LOCALNAME. It must not be a complete Tramp file name, but as long as there are necessary only. This function will be used in file name completion." (concat tramp-prefix-format @@ -1451,15 +1471,8 @@ necessary only. This function will be used in file name completion." (tramp-set-connection-property vec "process-buffer" (tramp-get-connection-property vec "process-buffer" nil)) - (setq buffer-undo-list t) - (setq default-directory - (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - (tramp-file-name-host vec) - (tramp-file-name-port vec) - "/")) + (setq buffer-undo-list t + default-directory (tramp-make-tramp-file-name vec "/" 'nohop)) (current-buffer)))) (defun tramp-get-connection-buffer (vec) @@ -1614,10 +1627,11 @@ ARGUMENTS to actually emit the message (if applicable)." ;; The message. (insert (apply #'format-message fmt-string arguments)))) -(defvar tramp-message-show-message t +(defvar tramp-message-show-message (null noninteractive) "Show Tramp message in the minibuffer. -This variable is used to disable messages from `tramp-error'. -The messages are visible anyway, because an error is raised.") +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.") (defsubst tramp-message (vec-or-proc level fmt-string &rest arguments) "Emit a message depending on verbosity level. @@ -2052,6 +2066,7 @@ pass to the OPERATION." `(tramp-file-name-handler tramp-vc-file-name-handler tramp-completion-file-name-handler + tramp-archive-file-name-handler cygwin-mount-name-hook-function cygwin-mount-map-drive-hook-function . @@ -2217,6 +2232,8 @@ Falls back to normal file name handler if no Tramp file name handler exists." (let ((default-directory (tramp-compat-temporary-file-directory))) (load (cadr sf) 'noerror 'nomessage))) +;; (tramp-message +;; v 4 "Running `%s'..." (cons operation args)) ;; If `non-essential' is non-nil, Tramp shall ;; not open a new connection. ;; If Tramp detects that it shouldn't continue @@ -2240,6 +2257,8 @@ Falls back to normal file name handler if no Tramp file name handler exists." (let ((tramp-locker t)) (apply foreign operation args)) (setq tramp-locked tl)))))) +;; (tramp-message +;; v 4 "Running `%s'...`%s'" (cons operation args) result) (cond ((eq result 'non-essential) (tramp-message @@ -2352,15 +2371,19 @@ remote file names." (defun tramp-register-file-name-handlers () "Add Tramp file name handlers to `file-name-handler-alist'." ;; Remove autoloaded handlers from file name handler alist. Useful, - ;; if `tramp-syntax' has been changed. + ;; if `tramp-syntax' has been changed. We cannot call + ;; `tramp-unload-file-name-handlers', this would result in recursive + ;; loading of Tramp. (dolist (fnh '(tramp-file-name-handler tramp-completion-file-name-handler + tramp-archive-file-name-handler tramp-autoload-file-name-handler)) (let ((a1 (rassq fnh file-name-handler-alist))) (setq file-name-handler-alist (delq a1 file-name-handler-alist)))) ;; Add the handlers. We do not add anything to the `operations' - ;; property of `tramp-file-name-handler', this shall be done by the + ;; property of `tramp-file-name-handler' and + ;; `tramp-archive-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)) @@ -2374,6 +2397,11 @@ remote file names." (put 'tramp-completion-file-name-handler 'operations (mapcar 'car tramp-completion-file-name-handler-alist)) + (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) + ;; 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)) @@ -2427,6 +2455,7 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." "Unload Tramp file name handlers from `file-name-handler-alist'." (dolist (fnh '(tramp-file-name-handler tramp-completion-file-name-handler + tramp-archive-file-name-handler tramp-autoload-file-name-handler)) (let ((a1 (rassq fnh file-name-handler-alist))) (setq file-name-handler-alist (delq a1 file-name-handler-alist)))))) @@ -2488,7 +2517,6 @@ not in completion mode." (host (tramp-file-name-host elt)) (localname (tramp-file-name-localname elt)) (m (tramp-find-method method user host)) - (tramp-current-user user) ; see `tramp-parse-passwd' all-user-hosts) (unless localname ;; Nothing to complete. @@ -2926,8 +2954,8 @@ User is always nil." localname))))) (tramp-error v 'file-already-exists newname) (delete-file newname))) - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) + (tramp-flush-file-properties v (file-name-directory localname)) + (tramp-flush-file-properties v localname) (copy-file filename newname 'ok-if-already-exists 'keep-time 'preserve-uid-gid 'preserve-permissions))) @@ -2971,13 +2999,19 @@ User is always nil." "Like `dired-uncache' for Tramp files." (with-parsed-tramp-file-name (if (file-directory-p dir) dir (file-name-directory dir)) nil - (tramp-flush-directory-property v localname))) + (tramp-flush-directory-properties v localname))) (defun tramp-handle-file-accessible-directory-p (filename) "Like `file-accessible-directory-p' for Tramp files." (and (file-directory-p filename) (file-readable-p filename))) +(defun tramp-handle-file-directory-p (filename) + "Like `file-directory-p' for Tramp files." + (eq (tramp-compat-file-attribute-type + (file-attributes (file-truename filename))) + t)) + (defun tramp-handle-file-equal-p (filename1 filename2) "Like `file-equalp-p' for Tramp files." ;; Native `file-equalp-p' calls `file-truename', which requires a @@ -3018,17 +3052,11 @@ User is always nil." ;; Run the command on the localname portion only unless we are in ;; completion mode. (tramp-make-tramp-file-name - (tramp-file-name-method v) - (tramp-file-name-user v) - (tramp-file-name-domain v) - (tramp-file-name-host v) - (tramp-file-name-port v) - (if (and (zerop (length (tramp-file-name-localname v))) - (not (tramp-connectable-p file))) - "" - (tramp-run-real-handler - 'file-name-as-directory (list (or (tramp-file-name-localname v) "")))) - (tramp-file-name-hop v)))) + v (unless (and (zerop (length (tramp-file-name-localname v))) + (not (tramp-connectable-p file))) + (tramp-run-real-handler + 'file-name-as-directory + (list (or (tramp-file-name-localname v) ""))))))) (defun tramp-handle-file-name-case-insensitive-p (filename) "Like `file-name-case-insensitive-p' for Tramp files." @@ -3087,10 +3115,6 @@ User is always nil." (defun tramp-handle-file-name-completion (filename directory &optional predicate) "Like `file-name-completion' for Tramp files." - (unless (tramp-tramp-file-p directory) - (error - "tramp-handle-file-name-completion invoked on non-tramp directory `%s'" - directory)) (let (hits-ignored-extensions) (or (try-completion @@ -3116,14 +3140,8 @@ User is always nil." (let ((v (tramp-dissect-file-name file t))) ;; Run the command on the localname portion only. (tramp-make-tramp-file-name - (tramp-file-name-method v) - (tramp-file-name-user v) - (tramp-file-name-domain v) - (tramp-file-name-host v) - (tramp-file-name-port v) - (tramp-run-real-handler - 'file-name-directory (list (or (tramp-file-name-localname v) ""))) - (tramp-file-name-hop v)))) + v (tramp-run-real-handler + 'file-name-directory (list (or (tramp-file-name-localname v) "")))))) (defun tramp-handle-file-name-nondirectory (file) "Like `file-name-nondirectory' but aware of Tramp files." @@ -3162,7 +3180,8 @@ User is always nil." (and (or (not connected) c) (cond ((eq identification 'method) method) - ;; Domain and port are appended. + ;; Domain and port are appended to user and host, + ;; respectively. ((eq identification 'user) (tramp-file-name-user-domain v)) ((eq identification 'host) (tramp-file-name-host-port v)) ((eq identification 'localname) localname) @@ -3574,29 +3593,28 @@ of." (eq (visited-file-modtime) 0) (not (file-remote-p f nil 'connected))) t - (with-parsed-tramp-file-name f nil - (let* ((remote-file-name-inhibit-cache t) - (attr (file-attributes f)) - (modtime (tramp-compat-file-attribute-modification-time attr)) - (mt (visited-file-modtime))) - - (cond - ;; File exists, and has a known modtime. - ((and attr (not (equal modtime '(0 0)))) - (< (abs (tramp-time-diff - modtime - ;; For compatibility, deal with both the old - ;; (HIGH . LOW) and the new (HIGH LOW) return - ;; values of `visited-file-modtime'. - (if (atom (cdr mt)) - (list (car mt) (cdr mt)) - mt))) - 2)) - ;; Modtime has the don't know value. - (attr t) - ;; If file does not exist, say it is not modified if and - ;; only if that agrees with the buffer's record. - (t (equal mt '(-1 65535)))))))))) + (let* ((remote-file-name-inhibit-cache t) + (attr (file-attributes f)) + (modtime (tramp-compat-file-attribute-modification-time attr)) + (mt (visited-file-modtime))) + + (cond + ;; File exists, and has a known modtime. + ((and attr (not (equal modtime '(0 0)))) + (< (abs (tramp-time-diff + modtime + ;; For compatibility, deal with both the old + ;; (HIGH . LOW) and the new (HIGH LOW) return + ;; values of `visited-file-modtime'. + (if (atom (cdr mt)) + (list (car mt) (cdr mt)) + mt))) + 2)) + ;; Modtime has the don't know value. + (attr t) + ;; If file does not exist, say it is not modified if and + ;; only if that agrees with the buffer's record. + (t (equal mt '(-1 65535))))))))) (defun tramp-handle-file-notify-add-watch (filename _flags _callback) "Like `file-notify-add-watch' for Tramp files." @@ -3633,17 +3651,16 @@ of." (defun tramp-action-login (_proc vec) "Send the login name." - (when (not (stringp tramp-current-user)) - (setq tramp-current-user - (with-tramp-connection-property vec "login-as" - (save-window-excursion - (let ((enable-recursive-minibuffers t)) - (pop-to-buffer (tramp-get-connection-buffer vec)) - (read-string (match-string 0))))))) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-message vec 6 "\n%s" (buffer-string))) - (tramp-message vec 3 "Sending login name `%s'" tramp-current-user) - (tramp-send-string vec (concat tramp-current-user tramp-local-end-of-line))) + (let ((user (or (tramp-file-name-user vec) + (with-tramp-connection-property vec "login-as" + (save-window-excursion + (let ((enable-recursive-minibuffers t)) + (pop-to-buffer (tramp-get-connection-buffer vec)) + (read-string (match-string 0)))))))) + (with-current-buffer (tramp-get-connection-buffer vec) + (tramp-message vec 6 "\n%s" (buffer-string))) + (tramp-message vec 3 "Sending login name `%s'" user) + (tramp-send-string vec (concat user tramp-local-end-of-line)))) (defun tramp-action-password (proc vec) "Query the user for a password." @@ -3767,12 +3784,11 @@ PROC and VEC indicate the remote connection to be used. POS, if set, is the starting point of the region to be deleted in the connection buffer." ;; Enable `auth-source', unless "emacs -Q" has been called. We must - ;; use `tramp-current-*' variables in case we have several hops. + ;; use the "password-vector" property in case we have several hops. (tramp-set-connection-property - (make-tramp-file-name - :method tramp-current-method :user tramp-current-user - :domain tramp-current-domain :host tramp-current-host - :port tramp-current-port) + (tramp-get-connection-property + proc "password-vector" + (tramp-get-connection-property proc "vector" nil)) "first-password-request" tramp-cache-read-persistent-data) (save-restriction (with-tramp-progress-reporter @@ -3823,7 +3839,9 @@ connection buffer." This is needed in order to hide `last-coding-system-used', which is set for process communication also." (with-current-buffer (process-buffer proc) - (let (buffer-read-only last-coding-system-used) + (let (buffer-read-only last-coding-system-used + ;; We do not want to run timers. + timer-list timer-idle-list) ;; Under Windows XP, `accept-process-output' doesn't return ;; sometimes. So we add an additional timeout. JUST-THIS-ONE ;; is set due to Bug#12145. It is an integer, in order to avoid @@ -4140,15 +4158,7 @@ be granted." vec (tramp-file-name-localname vec) (concat "file-attributes-" suffix) nil) (file-attributes - (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - (tramp-file-name-host vec) - (tramp-file-name-port vec) - (tramp-file-name-localname vec) - (tramp-file-name-hop vec)) - (intern suffix)))) + (tramp-make-tramp-file-name vec) (intern suffix)))) (remote-uid (tramp-get-connection-property vec (concat "uid-" suffix) nil)) @@ -4205,11 +4215,7 @@ be granted." ;; The local temp directory must be writable for the other user. (file-writable-p (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - host port - (tramp-compat-temporary-file-directory))) + 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 @@ -4219,14 +4225,9 @@ be granted." (defun tramp-get-remote-tmpdir (vec) "Return directory for temporary files on the remote host identified by VEC." (with-tramp-connection-property vec "tmpdir" - (let ((dir (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-domain vec) - (tramp-file-name-host vec) - (tramp-file-name-port vec) - (or (tramp-get-method-parameter vec 'tramp-tmpdir) "/tmp") - (tramp-file-name-hop vec)))) + (let ((dir + (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) (file-remote-p dir 'localname)) (tramp-error vec 'file-error "Directory %s not accessible" dir)) @@ -4339,15 +4340,10 @@ It always returns a return code. The Lisp error raised when PROGRAM is nil is trapped also, returning 1. Furthermore, traces are written with verbosity of 6." (let ((default-directory (tramp-compat-temporary-file-directory)) - (v (or vec - (make-tramp-file-name - :method tramp-current-method :user tramp-current-user - :domain tramp-current-domain :host tramp-current-host - :port tramp-current-port))) (destination (if (eq destination t) (current-buffer) destination)) output error result) (tramp-message - v 6 "`%s %s' %s %s" + vec 6 "`%s %s' %s %s" program (mapconcat 'identity args " ") infile destination) (condition-case err (with-temp-buffer @@ -4365,8 +4361,8 @@ are written with verbosity of 6." (setq error (error-message-string err) result 1))) (if (zerop (length error)) - (tramp-message v 6 "%d\n%s" result output) - (tramp-message v 6 "%d\n%s\n%s" result output error)) + (tramp-message vec 6 "%d\n%s" result output) + (tramp-message vec 6 "%d\n%s\n%s" result output error)) result)) (defun tramp-call-process-region @@ -4376,15 +4372,10 @@ It always returns a return code. The Lisp error raised when PROGRAM is nil is trapped also, returning 1. Furthermore, traces are written with verbosity of 6." (let ((default-directory (tramp-compat-temporary-file-directory)) - (v (or vec - (make-tramp-file-name - :method tramp-current-method :user tramp-current-user - :domain tramp-current-domain :host tramp-current-host - :port tramp-current-port))) (buffer (if (eq buffer t) (current-buffer) buffer)) result) (tramp-message - v 6 "`%s %s' %s %s %s %s" + vec 6 "`%s %s' %s %s %s %s" program (mapconcat 'identity args " ") start end delete buffer) (condition-case err (progn @@ -4397,11 +4388,11 @@ are written with verbosity of 6." (signal 'file-error (list result))) (with-current-buffer (if (bufferp buffer) buffer (current-buffer)) (if (zerop result) - (tramp-message v 6 "%d" result) - (tramp-message v 6 "%d\n%s" result (buffer-string))))) + (tramp-message vec 6 "%d" result) + (tramp-message vec 6 "%d\n%s" result (buffer-string))))) (error (setq result 1) - (tramp-message v 6 "%d\n%s" result (error-message-string err)))) + (tramp-message vec 6 "%d\n%s" result (error-message-string err)))) result)) ;;;###tramp-autoload @@ -4411,8 +4402,13 @@ Consults the auth-source package. Invokes `password-read' if available, `read-passwd' else." (let* ((case-fold-search t) (key (tramp-make-tramp-file-name - tramp-current-method tramp-current-user tramp-current-domain - tramp-current-host tramp-current-port "")) + ;; In tramp-sh.el, we must use "password-vector" due to + ;; multi-hop. + (tramp-get-connection-property + proc "password-vector" + ;; All other backends simply use "vector". + (tramp-get-connection-property proc "vector" nil)) + 'noloc 'nohop)) (pw-prompt (or prompt (with-current-buffer (process-buffer proc) @@ -4424,6 +4420,8 @@ Invokes `password-read' if available, `read-passwd' else." (unwind-protect (with-parsed-tramp-file-name key nil + (setq user + (or user (tramp-get-connection-property key "login-as" nil))) (prog1 (or ;; See if auth-sources contains something useful. @@ -4434,24 +4432,16 @@ Invokes `password-read' if available, `read-passwd' else." (setq auth-info (auth-source-search :max 1 - (and tramp-current-user :user) - (if tramp-current-domain - (format - "%s%s%s" - tramp-current-user tramp-prefix-domain-format - tramp-current-domain) - tramp-current-user) + (and user :user) + (if domain + (concat user tramp-prefix-domain-format domain) + user) :host - (if tramp-current-port - (format - "%s%s%s" - tramp-current-host tramp-prefix-port-format - tramp-current-port) - tramp-current-host) - :port tramp-current-method - :require - (cons - :secret (and tramp-current-user '(:user)))) + (if port + (concat host tramp-prefix-port-format port) + host) + :port method + :require (cons :secret (and user '(:user)))) auth-passwd (plist-get (nth 0 auth-info) :secret) auth-passwd (if (functionp auth-passwd) @@ -4471,11 +4461,7 @@ Invokes `password-read' if available, `read-passwd' else." (defun tramp-clear-passwd (vec) "Clear password cache for connection related to VEC." (let ((method (tramp-file-name-method vec)) - (user (tramp-file-name-user vec)) - (domain (tramp-file-name-domain vec)) (user-domain (tramp-file-name-user-domain vec)) - (host (tramp-file-name-host vec)) - (port (tramp-file-name-port vec)) (host-port (tramp-file-name-host-port vec)) (hop (tramp-file-name-hop vec))) (when hop @@ -4490,8 +4476,7 @@ Invokes `password-read' if available, `read-passwd' else." (auth-source-forget `(:max 1 ,(and user-domain :user) ,user-domain :host ,host-port :port ,method)) - (password-cache-remove - (tramp-make-tramp-file-name method user domain host port "")))) + (password-cache-remove (tramp-make-tramp-file-name vec 'noloc 'nohop)))) ;; Snarfed code from time-date.el. diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index 1a7727820ef..a9c9b0d751b 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -7,7 +7,7 @@ ;; Maintainer: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes ;; Package: tramp -;; Version: 2.3.3.26.1 +;; Version: 2.4.0-pre ;; This file is part of GNU Emacs. @@ -33,7 +33,7 @@ ;; should be changed only there. ;;;###tramp-autoload -(defconst tramp-version "2.3.3.26.1" +(defconst tramp-version "2.4.0-pre" "This version of Tramp.") ;;;###tramp-autoload @@ -55,7 +55,7 @@ ;; Check for Emacs version. (let ((x (if (>= emacs-major-version 24) "ok" - (format "Tramp 2.3.3.26.1 is not fit for %s" + (format "Tramp 2.4.0-pre is not fit for %s" (when (string-match "^.*$" (emacs-version)) (match-string 0 (emacs-version))))))) (unless (string-match "\\`ok\\'" x) (error "%s" x))) diff --git a/lisp/newcomment.el b/lisp/newcomment.el index f5615d93df3..9eb6875772e 100644 --- a/lisp/newcomment.el +++ b/lisp/newcomment.el @@ -527,7 +527,7 @@ Ensure that `comment-normalize-vars' has been called before you use this." ;; comment-search-backward is only used to find the comment-column (in ;; comment-set-column) and to find the comment-start string (via ;; comment-beginning) in indent-new-comment-line, it should be harmless. - (if (not (re-search-backward comment-start-skip limit t)) + (if (not (re-search-backward comment-start-skip limit 'move)) (unless noerror (error "No comment")) (beginning-of-line) (let* ((end (match-end 0)) diff --git a/lisp/nxml/rng-maint.el b/lisp/nxml/rng-maint.el index 46ab3a58f50..2b7d9cca082 100644 --- a/lisp/nxml/rng-maint.el +++ b/lisp/nxml/rng-maint.el @@ -226,11 +226,10 @@ (defun rng-time-function (function &rest args) (let* ((start (current-time)) - (val (apply function args)) - (end (current-time))) + (val (apply function args))) (message "%s ran in %g seconds" function - (float-time (time-subtract end start))) + (float-time (time-subtract nil start))) val)) (defun rng-time-tokenize-buffer () diff --git a/lisp/play/gamegrid.el b/lisp/play/gamegrid.el index 193b7da3bd7..6edd085b59a 100644 --- a/lisp/play/gamegrid.el +++ b/lisp/play/gamegrid.el @@ -1,4 +1,4 @@ -;;; gamegrid.el --- library for implementing grid-based games on Emacs +;;; gamegrid.el --- library for implementing grid-based games on Emacs -*- lexical-binding:t -*- ;; Copyright (C) 1997-1998, 2001-2018 Free Software Foundation, Inc. @@ -86,49 +86,157 @@ directory will be used.") (defvar gamegrid-mono-x-face nil) (defvar gamegrid-mono-tty-face nil) -;; ;;;;;;;;;;;;; constants ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defvar gamegrid-glyph-height-mm 7.0 + "Desired glyph height in mm.") -(defconst gamegrid-glyph-height 16) +;; ;;;;;;;;;;;;; glyph generation ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defconst gamegrid-xpm "\ +(defun gamegrid-calculate-glyph-size () + "Calculate appropriate glyph size in pixels based on display resolution. +Return a multiple of 8 no less than 16." + (if (and (display-pixel-height) (display-mm-height)) + (let* ((y-pitch (/ (display-pixel-height) (float (display-mm-height)))) + (pixels (* y-pitch gamegrid-glyph-height-mm)) + (rounded (* (floor (/ (+ pixels 4) 8)) 8))) + (max 16 rounded)) + 16)) + +;; Example of glyph in XPM format: +;; +;; /* XPM */ +;; static char *noname[] = { +;; /* width height ncolors chars_per_pixel */ +;; \"16 16 3 1\", +;; /* colors */ +;; \"+ s col1\", +;; \". s col2\", +;; \"- s col3\", +;; /* pixels */ +;; \"---------------+\", +;; \"--------------++\", +;; \"--............++\", +;; \"--............++\", +;; \"--............++\", +;; \"--............++\", +;; \"--............++\", +;; \"--............++\", +;; \"--............++\", +;; \"--............++\", +;; \"--............++\", +;; \"--............++\", +;; \"--............++\", +;; \"--............++\", +;; \"-+++++++++++++++\", +;; \"++++++++++++++++\" +;; }; + +(defun gamegrid-xpm () + "Generate the XPM format image used for each square." + (let* ((glyph-pixel-count (gamegrid-calculate-glyph-size)) + (border-pixel-count (/ glyph-pixel-count 8)) + (center-pixel-count (- glyph-pixel-count (* border-pixel-count 2)))) + (with-temp-buffer + (insert (format "\ /* XPM */ static char *noname[] = { /* width height ncolors chars_per_pixel */ -\"16 16 3 1\", +\"%s %s 3 1\", /* colors */ \"+ s col1\", \". s col2\", \"- s col3\", /* pixels */ -\"---------------+\", -\"--------------++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"--............++\", -\"-+++++++++++++++\", -\"++++++++++++++++\" -}; -" - "XPM format image used for each square") - -(defvar gamegrid-xbm "\ +" glyph-pixel-count glyph-pixel-count)) + + (dotimes (row border-pixel-count) + (let ((edge-pixel-count (+ row 1))) + (insert "\"") + (dotimes (_ (- glyph-pixel-count edge-pixel-count)) (insert "-")) + (dotimes (_ edge-pixel-count) (insert "+")) + (insert "\",\n"))) + + (let ((middle (format "\"%s%s%s\",\n" + (make-string border-pixel-count ?-) + (make-string center-pixel-count ?.) + (make-string border-pixel-count ?+)))) + (dotimes (_ center-pixel-count) (insert middle))) + + (dotimes (row border-pixel-count) + (let ((edge-pixel-count (- border-pixel-count row 1))) + (insert "\"") + (dotimes (_ edge-pixel-count) (insert "-")) + (dotimes (_ (- glyph-pixel-count edge-pixel-count)) (insert "+")) + (insert "\"") + (if (/= row (1- border-pixel-count)) + (insert ",\n") + (insert "\n};\n")))) + (buffer-string)))) + +;; Example of glyph in XBM format: +;; +;; /* gamegrid XBM */ +;; #define gamegrid_width 16 +;; #define gamegrid_height 16 +;; static unsigned char gamegrid_bits[] = { +;; 0xff, 0xff, 0xff, 0x7f, 0xff, 0x3f, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a, +;; 0x57, 0x15, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a, +;; 0x57, 0x15, 0x07, 0x00, 0x03, 0x00, 0x01, 0x00 }; + +(defun gamegrid-xbm () + "Generate XBM format image used for each square." + (let* ((glyph-pixel-count (gamegrid-calculate-glyph-size)) + (border-pixel-count (1- (/ glyph-pixel-count 4))) + (center-pixel-count (- glyph-pixel-count (* 2 border-pixel-count)))) + (with-temp-buffer + (insert (format "\ /* gamegrid XBM */ -#define gamegrid_width 16 -#define gamegrid_height 16 +#define gamegrid_width %s +#define gamegrid_height %s static unsigned char gamegrid_bits[] = { - 0xff, 0xff, 0xff, 0x7f, 0xff, 0x3f, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a, - 0x57, 0x15, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a, 0x57, 0x15, 0xaf, 0x0a, - 0x57, 0x15, 0x07, 0x00, 0x03, 0x00, 0x01, 0x00 };" - "XBM format image used for each square.") +" glyph-pixel-count glyph-pixel-count)) + (dotimes (row border-pixel-count) + (gamegrid-insert-xbm-bits + (concat (make-string (- glyph-pixel-count row) ?1) + (make-string row ?0))) + (insert ", \n")) + + (let* ((left-border (make-string border-pixel-count ?1)) + (right-border (make-string border-pixel-count ?0)) + (even-line (apply 'concat + (append (list left-border) + (make-list (/ center-pixel-count 2) "10") + (list right-border)))) + (odd-line (apply 'concat + (append (list left-border) + (make-list (/ center-pixel-count 2) "01") + (list right-border))))) + (dotimes (row center-pixel-count) + (gamegrid-insert-xbm-bits (if (eq (logand row 1) 1) odd-line even-line)) + (insert ", \n"))) + + (dotimes (row border-pixel-count) + (let ((edge-pixel-count (- border-pixel-count row))) + (gamegrid-insert-xbm-bits + (concat (make-string edge-pixel-count ?1) + (make-string (- glyph-pixel-count edge-pixel-count) ?0)))) + (if (/= row (1- border-pixel-count)) + (insert ", \n") + (insert " };\n"))) + (buffer-string)))) + +(defun gamegrid-insert-xbm-bits (str) + "Convert binary to hex and insert in current buffer. +STR should be a string composed of 1s and 0s and be a multiple of +8 in length. Divide it into 8 bit bytes, reverse the order of +each, convert them to hex and insert them in comma separated C +format." + (let ((byte-count (/ (length str) 8))) + (dotimes (i byte-count) + (let* ((byte (reverse (substring str (* i 8) (+ (* i 8) 8)))) + (value (string-to-number byte 2))) + (insert (format "0x%02x" value)) + (unless (= i (1- byte-count)) + (insert ", ")))))) ;; ;;;;;;;;;;;;;;;; miscellaneous functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -228,13 +336,13 @@ static unsigned char gamegrid_bits[] = { gamegrid-mono-tty-face)))) (defun gamegrid-colorize-glyph (color) - (find-image `((:type xpm :data ,gamegrid-xpm + (find-image `((:type xpm :data ,(gamegrid-xpm) :ascent center :color-symbols (("col1" . ,(gamegrid-color color 0.6)) ("col2" . ,(gamegrid-color color 0.8)) ("col3" . ,(gamegrid-color color 1.0)))) - (:type xbm :data ,gamegrid-xbm + (:type xbm :data ,(gamegrid-xbm) :ascent center :foreground ,(gamegrid-color color 1.0) :background ,(gamegrid-color color 0.5))))) @@ -376,7 +484,7 @@ static unsigned char gamegrid_bits[] = { (buffer-read-only nil)) (erase-buffer) (setq gamegrid-buffer-start (point)) - (dotimes (i height) + (dotimes (_ height) (insert line)) ;; Adjust the height of the default face to the height of the ;; images. Unlike XEmacs, Emacs doesn't allow making the default diff --git a/lisp/printing.el b/lisp/printing.el index 20b0790670d..2fc2323028f 100644 --- a/lisp/printing.el +++ b/lisp/printing.el @@ -2,8 +2,8 @@ ;; Copyright (C) 2000-2001, 2003-2018 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> -;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> +;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, print, PostScript ;; Version: 6.9.3 ;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre @@ -12,7 +12,7 @@ "printing.el, v 6.9.3 <2007/12/09 vinicius> Please send all bug fixes and enhancements to - bug-gnu-emacs@gnu.org and Vinicius Jose Latorre <viniciusjl@ig.com.br> + bug-gnu-emacs@gnu.org and Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ") ;; This file is part of GNU Emacs. diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index 6dbdba75de6..a62a974a99c 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -1,9 +1,10 @@ -;;; cperl-mode.el --- Perl code editing commands for Emacs +;;; cperl-mode.el --- Perl code editing commands for Emacs -*- lexical-binding:t -*- ;; Copyright (C) 1985-1987, 1991-2018 Free Software Foundation, Inc. ;; Author: Ilya Zakharevich ;; Bob Olson +;; Jonathan Rockway <jon@jrock.us> ;; Maintainer: emacs-devel@gnu.org ;; Keywords: languages, Perl @@ -22,10 +23,19 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. -;;; Corrections made by Ilya Zakharevich ilyaz@cpan.org +;; Corrections made by Ilya Zakharevich ilyaz@cpan.org ;;; Commentary: +;; This version of the file contains support for the syntax added by +;; the MooseX::Declare CPAN module, as well as Perl 5.10 keyword +;; support. + +;; The latest version is available from +;; http://github.com/jrockway/cperl-mode +;; +;; (perhaps in the moosex-declare branch) + ;; You can either fine-tune the bells and whistles of this mode or ;; bulk enable them by putting @@ -56,7 +66,7 @@ ;; (define-key global-map [M-S-down-mouse-3] 'imenu) -;;; Font lock bugs as of v4.32: +;;;; Font lock bugs as of v4.32: ;; The following kinds of Perl code erroneously start strings: ;; \$` \$' \$" @@ -65,6 +75,8 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + (defvar vc-rcs-header) (defvar vc-sccs-header) @@ -75,37 +87,11 @@ (condition-case nil (require 'man) (error nil)) - (defvar cperl-can-font-lock - (or (featurep 'xemacs) - (and (boundp 'emacs-major-version) - (or window-system - (> emacs-major-version 20))))) - (if cperl-can-font-lock - (require 'font-lock)) (defvar msb-menu-cond) (defvar gud-perldb-history) (defvar font-lock-background-mode) ; not in Emacs (defvar font-lock-display-type) ; ditto (defvar paren-backwards-message) ; Not in newer XEmacs? - (or (fboundp 'defgroup) - (defmacro defgroup (name val doc &rest arr) - nil)) - (or (fboundp 'custom-declare-variable) - (defmacro defcustom (name val doc &rest arr) - `(defvar ,name ,val ,doc))) - (or (and (fboundp 'custom-declare-variable) - (string< "19.31" emacs-version)) ; Checked with 19.30: defface does not work - (defmacro defface (&rest arr) - nil)) - ;; Avoid warning (tmp definitions) - (or (fboundp 'x-color-defined-p) - (defmacro x-color-defined-p (col) - (cond ((fboundp 'color-defined-p) `(color-defined-p ,col)) - ;; XEmacs >= 19.12 - ((fboundp 'valid-color-name-p) `(valid-color-name-p ,col)) - ;; XEmacs 19.11 - ((fboundp 'x-valid-color-name-p) `(x-valid-color-name-p ,col)) - (t '(error "Cannot implement color-defined-p"))))) (defmacro cperl-is-face (arg) ; Takes quoted arg (cond ((fboundp 'find-face) `(find-face ,arg)) @@ -132,7 +118,7 @@ `(progn (beginning-of-line 2) (list ,file ,line))) - (defmacro cperl-etags-snarf-tag (file line) + (defmacro cperl-etags-snarf-tag (_file _line) `(etags-snarf-tag))) (if (featurep 'xemacs) (defmacro cperl-etags-goto-tag-location (elt) @@ -147,12 +133,6 @@ (defmacro cperl-etags-goto-tag-location (elt) `(etags-goto-tag-location ,elt)))) -(defvar cperl-can-font-lock - (or (featurep 'xemacs) - (and (boundp 'emacs-major-version) - (or window-system - (> emacs-major-version 20))))) - (defun cperl-choose-color (&rest list) (let (answer) (while list @@ -228,10 +208,10 @@ for constructs with multiline if/unless/while/until/for/foreach condition." :type 'integer :group 'cperl-indentation-details) -;; Is is not unusual to put both things like perl-indent-level and -;; cperl-indent-level in the local variable section of a file. If only +;; It is not unusual to put both things like perl-indent-level and +;; cperl-indent-level in the local variable section of a file. If only ;; one of perl-mode and cperl-mode is in use, a warning will be issued -;; about the variable. Autoload these here, so that no warning is +;; about the variable. Autoload these here, so that no warning is ;; issued when using either perl-mode or cperl-mode. ;;;###autoload(put 'cperl-indent-level 'safe-local-variable 'integerp) ;;;###autoload(put 'cperl-brace-offset 'safe-local-variable 'integerp) @@ -286,6 +266,11 @@ Versions 5.2 ... 5.20 behaved as if this were nil." :type 'boolean :group 'cperl-indentation-details) +(defcustom cperl-indent-subs-specially t + "*Non-nil means indent subs that are inside other blocks (hash values, for example) relative to the beginning of the \"sub\" keyword, rather than relative to the statement that contains the declaration." + :type 'boolean + :group 'cperl-indentation-details) + (defcustom cperl-auto-newline nil "Non-nil means automatically newline before and after braces, and after colons and semicolons, inserted in CPerl code. The following @@ -458,7 +443,7 @@ Font for POD headers." :type 'face :group 'cperl-faces) -;;; Some double-evaluation happened with font-locks... Needed with 21.2... +;; Some double-evaluation happened with font-locks... Needed with 21.2... (defvar cperl-singly-quote-face (featurep 'xemacs)) (defcustom cperl-invalid-face 'underline @@ -612,8 +597,7 @@ One should tune up `cperl-close-paren-offset' as well." :group 'cperl-indentation-details) (defcustom cperl-syntaxify-by-font-lock - (and cperl-can-font-lock - (boundp 'parse-sexp-lookup-properties)) + (boundp 'parse-sexp-lookup-properties) "Non-nil means that CPerl uses the `font-lock' routines for syntaxification." :type '(choice (const message) boolean) :group 'cperl-speed) @@ -1010,33 +994,15 @@ In regular expressions (including character classes): (and (vectorp cperl-del-back-ch) (= (length cperl-del-back-ch) 1) (setq cperl-del-back-ch (aref cperl-del-back-ch 0))) -(defun cperl-mark-active () (mark)) ; Avoid undefined warning -(if (featurep 'xemacs) - (progn - ;; "Active regions" are on: use region only if active - ;; "Active regions" are off: use region unconditionally - (defun cperl-use-region-p () - (if zmacs-regions (mark) t))) - (defun cperl-use-region-p () - (if transient-mark-mode mark-active t)) - (defun cperl-mark-active () mark-active)) - -(defsubst cperl-enable-font-lock () - cperl-can-font-lock) - (defun cperl-putback-char (c) ; Emacs 19 (push c unread-command-events)) ; Avoid undefined warning (if (featurep 'xemacs) (defun cperl-putback-char (c) ; XEmacs >= 19.12 - (push (eval '(character-to-event c)) unread-command-events))) - -(or (fboundp 'uncomment-region) - (defun uncomment-region (beg end) - (interactive "r") - (comment-region beg end -1))) + (push (character-to-event c) unread-command-events))) (defvar cperl-do-not-fontify + ;; FIXME: This is not doing what it claims! (if (string< emacs-version "19.30") 'fontified 'lazy-lock) @@ -1056,8 +1022,6 @@ In regular expressions (including character classes): (defvar cperl-syntax-state nil) (defvar cperl-syntax-done-to nil) -(defvar cperl-emacs-can-parse (> (length (save-excursion - (parse-partial-sexp (point) (point)))) 9)) ;; Make customization possible "in reverse" (defsubst cperl-val (symbol &optional default hairy) @@ -1085,141 +1049,126 @@ versions of Emacs." (put-text-property (point) (match-end 0) 'syntax-type prop))))))) -;;; Probably it is too late to set these guys already, but it can help later: +;; Probably it is too late to set these guys already, but it can help later: -;;;(and cperl-clobber-mode-lists -;;;(setq auto-mode-alist -;;; (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode)) auto-mode-alist )) -;;;(and (boundp 'interpreter-mode-alist) -;;; (setq interpreter-mode-alist (append interpreter-mode-alist -;;; '(("miniperl" . perl-mode)))))) +;;(and cperl-clobber-mode-lists +;;(setq auto-mode-alist +;; (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode)) auto-mode-alist )) +;;(and (boundp 'interpreter-mode-alist) +;; (setq interpreter-mode-alist (append interpreter-mode-alist +;; '(("miniperl" . perl-mode)))))) (eval-when-compile - (mapc (lambda (p) - (condition-case nil - (require p) - (error nil))) - '(imenu easymenu etags timer man info)) - (if (fboundp 'ps-extend-face-list) - (defmacro cperl-ps-extend-face-list (arg) - `(ps-extend-face-list ,arg)) - (defmacro cperl-ps-extend-face-list (arg) - `(error "This version of Emacs has no `ps-extend-face-list'"))) - ;; Calling `cperl-enable-font-lock' below doesn't compile on XEmacs, - ;; macros instead of defsubsts don't work on Emacs, so we do the - ;; expansion manually. Any other suggestions? - (require 'cl)) - -(define-abbrev-table 'cperl-mode-abbrev-table - '( - ("if" "if" cperl-electric-keyword :system t) - ("elsif" "elsif" cperl-electric-keyword :system t) - ("while" "while" cperl-electric-keyword :system t) - ("until" "until" cperl-electric-keyword :system t) - ("unless" "unless" cperl-electric-keyword :system t) - ("else" "else" cperl-electric-else :system t) - ("continue" "continue" cperl-electric-else :system t) - ("for" "for" cperl-electric-keyword :system t) - ("foreach" "foreach" cperl-electric-keyword :system t) - ("formy" "formy" cperl-electric-keyword :system t) - ("foreachmy" "foreachmy" cperl-electric-keyword :system t) - ("do" "do" cperl-electric-keyword :system t) - ("=pod" "=pod" cperl-electric-pod :system t) - ("=over" "=over" cperl-electric-pod :system t) - ("=head1" "=head1" cperl-electric-pod :system t) - ("=head2" "=head2" cperl-electric-pod :system t) - ("pod" "pod" cperl-electric-pod :system t) - ("over" "over" cperl-electric-pod :system t) - ("head1" "head1" cperl-electric-pod :system t) - ("head2" "head2" cperl-electric-pod :system t)) - "Abbrev table in use in CPerl mode buffers.") - -(add-hook 'edit-var-mode-alist '(perl-mode (regexp . "^cperl-"))) - -(defvar cperl-mode-map () "Keymap used in CPerl mode.") - -(if cperl-mode-map nil - (setq cperl-mode-map (make-sparse-keymap)) - (cperl-define-key "{" 'cperl-electric-lbrace) - (cperl-define-key "[" 'cperl-electric-paren) - (cperl-define-key "(" 'cperl-electric-paren) - (cperl-define-key "<" 'cperl-electric-paren) - (cperl-define-key "}" 'cperl-electric-brace) - (cperl-define-key "]" 'cperl-electric-rparen) - (cperl-define-key ")" 'cperl-electric-rparen) - (cperl-define-key ";" 'cperl-electric-semi) - (cperl-define-key ":" 'cperl-electric-terminator) - (cperl-define-key "\C-j" 'newline-and-indent) - (cperl-define-key "\C-c\C-j" 'cperl-linefeed) - (cperl-define-key "\C-c\C-t" 'cperl-invert-if-unless) - (cperl-define-key "\C-c\C-a" 'cperl-toggle-auto-newline) - (cperl-define-key "\C-c\C-k" 'cperl-toggle-abbrev) - (cperl-define-key "\C-c\C-w" 'cperl-toggle-construct-fix) - (cperl-define-key "\C-c\C-f" 'auto-fill-mode) - (cperl-define-key "\C-c\C-e" 'cperl-toggle-electric) - (cperl-define-key "\C-c\C-b" 'cperl-find-bad-style) - (cperl-define-key "\C-c\C-p" 'cperl-pod-spell) - (cperl-define-key "\C-c\C-d" 'cperl-here-doc-spell) - (cperl-define-key "\C-c\C-n" 'cperl-narrow-to-here-doc) - (cperl-define-key "\C-c\C-v" 'cperl-next-interpolated-REx) - (cperl-define-key "\C-c\C-x" 'cperl-next-interpolated-REx-0) - (cperl-define-key "\C-c\C-y" 'cperl-next-interpolated-REx-1) - (cperl-define-key "\C-c\C-ha" 'cperl-toggle-autohelp) - (cperl-define-key "\C-c\C-hp" 'cperl-perldoc) - (cperl-define-key "\C-c\C-hP" 'cperl-perldoc-at-point) - (cperl-define-key "\e\C-q" 'cperl-indent-exp) ; Usually not bound - (cperl-define-key [?\C-\M-\|] 'cperl-lineup - [(control meta |)]) - ;;(cperl-define-key "\M-q" 'cperl-fill-paragraph) - ;;(cperl-define-key "\e;" 'cperl-indent-for-comment) - (cperl-define-key "\177" 'cperl-electric-backspace) - (cperl-define-key "\t" 'cperl-indent-command) - ;; don't clobber the backspace binding: - (cperl-define-key "\C-c\C-hF" 'cperl-info-on-command - [(control c) (control h) F]) - (if (cperl-val 'cperl-clobber-lisp-bindings) - (progn - (cperl-define-key "\C-hf" - ;;(concat (char-to-string help-char) "f") ; does not work - 'cperl-info-on-command - [(control h) f]) - (cperl-define-key "\C-hv" - ;;(concat (char-to-string help-char) "v") ; does not work - 'cperl-get-help - [(control h) v]) - (cperl-define-key "\C-c\C-hf" - ;;(concat (char-to-string help-char) "f") ; does not work - (key-binding "\C-hf") - [(control c) (control h) f]) - (cperl-define-key "\C-c\C-hv" - ;;(concat (char-to-string help-char) "v") ; does not work - (key-binding "\C-hv") - [(control c) (control h) v])) - (cperl-define-key "\C-c\C-hf" 'cperl-info-on-current-command - [(control c) (control h) f]) - (cperl-define-key "\C-c\C-hv" - ;;(concat (char-to-string help-char) "v") ; does not work - 'cperl-get-help - [(control c) (control h) v])) - (if (and (featurep 'xemacs) - (<= emacs-minor-version 11) (<= emacs-major-version 19)) - (progn - ;; substitute-key-definition is usefulness-deenhanced... - ;;;;;(cperl-define-key "\M-q" 'cperl-fill-paragraph) - (cperl-define-key "\e;" 'cperl-indent-for-comment) - (cperl-define-key "\e\C-\\" 'cperl-indent-region)) + (mapc #'require '(imenu easymenu etags timer man info))) + +(define-abbrev-table 'cperl-mode-electric-keywords-abbrev-table + (mapcar (lambda (x) + (let ((name (car x)) + (fun (cadr x))) + (list name name fun :system t))) + '(("if" cperl-electric-keyword) + ("elsif" cperl-electric-keyword) + ("while" cperl-electric-keyword) + ("until" cperl-electric-keyword) + ("unless" cperl-electric-keyword) + ("else" cperl-electric-else) + ("continue" cperl-electric-else) + ("for" cperl-electric-keyword) + ("foreach" cperl-electric-keyword) + ("formy" cperl-electric-keyword) + ("foreachmy" cperl-electric-keyword) + ("do" cperl-electric-keyword) + ("=pod" cperl-electric-pod) + ("=begin" cperl-electric-pod t) + ("=over" cperl-electric-pod) + ("=head1" cperl-electric-pod) + ("=head2" cperl-electric-pod) + ("pod" cperl-electric-pod) + ("over" cperl-electric-pod) + ("head1" cperl-electric-pod) + ("head2" cperl-electric-pod))) + "Abbrev table for electric keywords. Controlled by `cperl-electric-keywords'." + :case-fixed t + :enable-function (lambda () (cperl-val 'cperl-electric-keywords))) + +(define-abbrev-table 'cperl-mode-abbrev-table () + "Abbrev table in use in CPerl mode buffers." + :parents (list cperl-mode-electric-keywords-abbrev-table)) + +(when (boundp 'edit-var-mode-alist) + ;; FIXME: What package uses this? + (add-to-list 'edit-var-mode-alist '(perl-mode (regexp . "^cperl-")))) + +(defvar cperl-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "{" 'cperl-electric-lbrace) + (define-key map "[" 'cperl-electric-paren) + (define-key map "(" 'cperl-electric-paren) + (define-key map "<" 'cperl-electric-paren) + (define-key map "}" 'cperl-electric-brace) + (define-key map "]" 'cperl-electric-rparen) + (define-key map ")" 'cperl-electric-rparen) + (define-key map ";" 'cperl-electric-semi) + (define-key map ":" 'cperl-electric-terminator) + (define-key map "\C-j" 'newline-and-indent) + (define-key map "\C-c\C-j" 'cperl-linefeed) + (define-key map "\C-c\C-t" 'cperl-invert-if-unless) + (define-key map "\C-c\C-a" 'cperl-toggle-auto-newline) + (define-key map "\C-c\C-k" 'cperl-toggle-abbrev) + (define-key map "\C-c\C-w" 'cperl-toggle-construct-fix) + (define-key map "\C-c\C-f" 'auto-fill-mode) + (define-key map "\C-c\C-e" 'cperl-toggle-electric) + (define-key map "\C-c\C-b" 'cperl-find-bad-style) + (define-key map "\C-c\C-p" 'cperl-pod-spell) + (define-key map "\C-c\C-d" 'cperl-here-doc-spell) + (define-key map "\C-c\C-n" 'cperl-narrow-to-here-doc) + (define-key map "\C-c\C-v" 'cperl-next-interpolated-REx) + (define-key map "\C-c\C-x" 'cperl-next-interpolated-REx-0) + (define-key map "\C-c\C-y" 'cperl-next-interpolated-REx-1) + (define-key map "\C-c\C-ha" 'cperl-toggle-autohelp) + (define-key map "\C-c\C-hp" 'cperl-perldoc) + (define-key map "\C-c\C-hP" 'cperl-perldoc-at-point) + (define-key map "\e\C-q" 'cperl-indent-exp) ; Usually not bound + (define-key map [(control meta ?|)] 'cperl-lineup) + ;;(define-key map "\M-q" 'cperl-fill-paragraph) + ;;(define-key map "\e;" 'cperl-indent-for-comment) + (define-key map "\177" 'cperl-electric-backspace) + (define-key map "\t" 'cperl-indent-command) + ;; don't clobber the backspace binding: + (define-key map [(control ?c) (control ?h) ?F] 'cperl-info-on-command) + (if (cperl-val 'cperl-clobber-lisp-bindings) + (progn + (define-key map [(control ?h) ?f] + ;;(concat (char-to-string help-char) "f") ; does not work + 'cperl-info-on-command) + (define-key map [(control ?h) ?v] + ;;(concat (char-to-string help-char) "v") ; does not work + 'cperl-get-help) + (define-key map [(control ?c) (control ?h) ?f] + ;;(concat (char-to-string help-char) "f") ; does not work + (key-binding "\C-hf")) + (define-key map [(control ?c) (control ?h) ?v] + ;;(concat (char-to-string help-char) "v") ; does not work + (key-binding "\C-hv"))) + (define-key map [(control ?c) (control ?h) ?f] + 'cperl-info-on-current-command) + (define-key map [(control ?c) (control ?h) ?v] + ;;(concat (char-to-string help-char) "v") ; does not work + 'cperl-get-help)) (or (boundp 'fill-paragraph-function) - (substitute-key-definition - 'fill-paragraph 'cperl-fill-paragraph - cperl-mode-map global-map)) + (substitute-key-definition + 'fill-paragraph 'cperl-fill-paragraph + map global-map)) (substitute-key-definition 'indent-sexp 'cperl-indent-exp - cperl-mode-map global-map) + map global-map) (substitute-key-definition 'indent-region 'cperl-indent-region - cperl-mode-map global-map) + map global-map) (substitute-key-definition 'indent-for-comment 'cperl-indent-for-comment - cperl-mode-map global-map))) + map global-map) + map) + "Keymap used in CPerl mode.") (defvar cperl-menu) (defvar cperl-lazy-installed) @@ -1236,7 +1185,7 @@ versions of Emacs." ["Indent expression" cperl-indent-exp t] ["Fill paragraph/comment" fill-paragraph t] "----" - ["Line up a construction" cperl-lineup (cperl-use-region-p)] + ["Line up a construction" cperl-lineup (use-region-p)] ["Invert if/unless/while etc" cperl-invert-if-unless t] ("Regexp" ["Beautify" cperl-beautify-regexp @@ -1264,9 +1213,9 @@ versions of Emacs." ["Insert spaces if needed to fix style" cperl-find-bad-style t] ["Refresh \"hard\" constructions" cperl-find-pods-heres t] "----" - ["Indent region" cperl-indent-region (cperl-use-region-p)] - ["Comment region" cperl-comment-region (cperl-use-region-p)] - ["Uncomment region" cperl-uncomment-region (cperl-use-region-p)] + ["Indent region" cperl-indent-region (use-region-p)] + ["Comment region" cperl-comment-region (use-region-p)] + ["Uncomment region" cperl-uncomment-region (use-region-p)] "----" ["Run" mode-compile (fboundp 'mode-compile)] ["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill) @@ -1313,7 +1262,7 @@ versions of Emacs." (fboundp 'ps-extend-face-list)] "----" ["Syntaxify region" cperl-find-pods-heres-region - (cperl-use-region-p)] + (use-region-p)] ["Profile syntaxification" cperl-time-fontification t] ["Debug errors in delayed fontification" cperl-emulate-lazy-lock t] ["Debug unwind for syntactic scan" cperl-toggle-set-debug-unwind t] @@ -1323,15 +1272,15 @@ versions of Emacs." ["Class Hierarchy from TAGS" cperl-tags-hier-init t] ;;["Update classes" (cperl-tags-hier-init t) tags-table-list] ("Tags" -;;; ["Create tags for current file" cperl-etags t] -;;; ["Add tags for current file" (cperl-etags t) t] -;;; ["Create tags for Perl files in directory" (cperl-etags nil t) t] -;;; ["Add tags for Perl files in directory" (cperl-etags t t) t] -;;; ["Create tags for Perl files in (sub)directories" -;;; (cperl-etags nil 'recursive) t] -;;; ["Add tags for Perl files in (sub)directories" -;;; (cperl-etags t 'recursive) t]) -;;;; cperl-write-tags (&optional file erase recurse dir inbuffer) + ;; ["Create tags for current file" cperl-etags t] + ;; ["Add tags for current file" (cperl-etags t) t] + ;; ["Create tags for Perl files in directory" (cperl-etags nil t) t] + ;; ["Add tags for Perl files in directory" (cperl-etags t t) t] + ;; ["Create tags for Perl files in (sub)directories" + ;; (cperl-etags nil 'recursive) t] + ;; ["Add tags for Perl files in (sub)directories" + ;; (cperl-etags t 'recursive) t]) + ;; ;;? cperl-write-tags (&optional file erase recurse dir inbuffer) ["Create tags for current file" (cperl-write-tags nil t) t] ["Add tags for current file" (cperl-write-tags) t] ["Create tags for Perl files in directory" @@ -1352,11 +1301,9 @@ versions of Emacs." ["Perldoc on word at point" cperl-perldoc-at-point t] ["View manpage of POD in this file" cperl-build-manpage t] ["Auto-help on" cperl-lazy-install - (and (fboundp 'run-with-idle-timer) - (not cperl-lazy-installed))] + (not cperl-lazy-installed)] ["Auto-help off" cperl-lazy-unstall - (and (fboundp 'run-with-idle-timer) - cperl-lazy-installed)]) + cperl-lazy-installed]) ("Toggle..." ["Auto newline" cperl-toggle-auto-newline t] ["Electric parens" cperl-toggle-electric t] @@ -1383,7 +1330,8 @@ versions of Emacs." ["CPerl mode" (describe-function 'cperl-mode) t] ["CPerl version" (message "The version of master-file for this CPerl is %s-Emacs" - cperl-version) t])))) + cperl-version) + t])))) (error nil)) (autoload 'c-macro-expand "cmacexp" @@ -1391,22 +1339,22 @@ versions of Emacs." The expansion is entirely correct because it uses the C preprocessor." t) -;;; These two must be unwound, otherwise take exponential time +;; These two must be unwound, otherwise take exponential time (defconst cperl-maybe-white-and-comment-rex "[ \t\n]*\\(#[^\n]*\n[ \t\n]*\\)*" "Regular expression to match optional whitespace with interspersed comments. Should contain exactly one group.") -;;; This one is tricky to unwind; still very inefficient... +;; This one is tricky to unwind; still very inefficient... (defconst cperl-white-and-comment-rex "\\([ \t\n]\\|#[^\n]*\n\\)+" "Regular expression to match whitespace with interspersed comments. Should contain exactly one group.") -;;; Is incorporated in `cperl-imenu--function-name-regexp-perl' -;;; `cperl-outline-regexp', `defun-prompt-regexp'. -;;; Details of groups in this may be used in several functions; see comments -;;; near mentioned above variable(s)... -;;; sub($$):lvalue{} sub:lvalue{} Both allowed... +;; Is incorporated in `cperl-imenu--function-name-regexp-perl' +;; `cperl-outline-regexp', `defun-prompt-regexp'. +;; Details of groups in this may be used in several functions; see comments +;; near mentioned above variable(s)... +;; sub($$):lvalue{} sub:lvalue{} Both allowed... (defsubst cperl-after-sub-regexp (named attr) ; 9 groups without attr... "Match the text after `sub' in a subroutine declaration. If NAMED is nil, allows anonymous subroutines. Matches up to the first \":\" @@ -1441,9 +1389,22 @@ the last)." "\\)?" ; END n+6=proto-group )) -;;; Details of groups in this are used in `cperl-imenu--create-perl-index' -;;; and `cperl-outline-level'. -;;;; Was: 2=sub|package; now 2=package-group, 5=package-name 8=sub-name (+3) +;; Tired of editing this in 8 places every time I remember that there +;; is another method-defining keyword +(defvar cperl-sub-keywords + '("sub")) + +(defvar cperl-sub-regexp (regexp-opt cperl-sub-keywords)) + +(defun cperl-char-ends-sub-keyword-p (char) + "Return T if CHAR is the last character of a perl sub keyword." + (cl-loop for keyword in cperl-sub-keywords + when (eq char (aref keyword (1- (length keyword)))) + return t)) + +;; Details of groups in this are used in `cperl-imenu--create-perl-index' +;; and `cperl-outline-level'. +;; Was: 2=sub|package; now 2=package-group, 5=package-name 8=sub-name (+3) (defvar cperl-imenu--function-name-regexp-perl (concat "^\\(" ; 1 = all @@ -1452,7 +1413,8 @@ the last)." cperl-white-and-comment-rex ; 4 = pre-package-name "\\([a-zA-Z_0-9:']+\\)\\)?\\)" ; 5 = package-name "\\|" - "[ \t]*sub" + "[ \t]*" + cperl-sub-regexp (cperl-after-sub-regexp 'named nil) ; 8=name 11=proto 14=attr-start cperl-maybe-white-and-comment-rex ; 15=pre-block "\\|" @@ -1624,7 +1586,7 @@ It is possible to show this help automatically after some idle time. This is regulated by variable `cperl-lazy-help-time'. Default with `cperl-hairy' (if the value of `cperl-lazy-help-time' is nil) is 5 secs idle time . It is also possible to switch this on/off from the -menu, or via \\[cperl-toggle-autohelp]. Requires `run-with-idle-timer'. +menu, or via \\[cperl-toggle-autohelp]. Use \\[cperl-lineup] to vertically lineup some construction - put the beginning of the region at the start of construction, and make region @@ -1719,107 +1681,74 @@ or as help on variables `cperl-tips', `cperl-problems', ;; Until Emacs is multi-threaded, we do not actually need it local: (make-local-variable 'cperl-font-lock-multiline-start) (make-local-variable 'cperl-font-locking) - (make-local-variable 'outline-regexp) - ;; (setq outline-regexp imenu-example--function-name-regexp-perl) - (setq outline-regexp cperl-outline-regexp) - (make-local-variable 'outline-level) - (setq outline-level 'cperl-outline-level) - (make-local-variable 'add-log-current-defun-function) - (setq add-log-current-defun-function + (set (make-local-variable 'outline-regexp) cperl-outline-regexp) + (set (make-local-variable 'outline-level) 'cperl-outline-level) + (set (make-local-variable 'add-log-current-defun-function) (lambda () (save-excursion (if (re-search-backward "^sub[ \t]+\\([^({ \t\n]+\\)" nil t) (match-string-no-properties 1))))) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "^$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) + (set (make-local-variable 'paragraph-start) (concat "^$\\|" page-delimiter)) + (set (make-local-variable 'paragraph-separate) paragraph-start) + (set (make-local-variable 'paragraph-ignore-fill-prefix) t) (if (featurep 'xemacs) - (progn - (make-local-variable 'paren-backwards-message) - (set 'paren-backwards-message t))) - (make-local-variable 'indent-line-function) - (setq indent-line-function 'cperl-indent-line) - (make-local-variable 'require-final-newline) - (setq require-final-newline mode-require-final-newline) - (make-local-variable 'comment-start) - (setq comment-start "# ") - (make-local-variable 'comment-end) - (setq comment-end "") - (make-local-variable 'comment-column) - (setq comment-column cperl-comment-column) - (make-local-variable 'comment-start-skip) - (setq comment-start-skip "#+ *") - (make-local-variable 'defun-prompt-regexp) -;;; "[ \t]*sub" -;;; (cperl-after-sub-regexp 'named nil) ; 8=name 11=proto 14=attr-start -;;; cperl-maybe-white-and-comment-rex ; 15=pre-block - (setq defun-prompt-regexp - (concat "^[ \t]*\\(sub" - (cperl-after-sub-regexp 'named 'attr-groups) - "\\|" ; per toke.c - "\\(BEGIN\\|CHECK\\|INIT\\|END\\|AUTOLOAD\\|DESTROY\\)" - "\\)" - cperl-maybe-white-and-comment-rex)) - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'cperl-comment-indent) + (set (make-local-variable 'paren-backwards-message) t)) + (set (make-local-variable 'indent-line-function) #'cperl-indent-line) + (set (make-local-variable 'require-final-newline) mode-require-final-newline) + (set (make-local-variable 'comment-start) "# ") + (set (make-local-variable 'comment-end) "") + (set (make-local-variable 'comment-column) cperl-comment-column) + (set (make-local-variable 'comment-start-skip) "#+ *") + +;; "[ \t]*sub" +;; (cperl-after-sub-regexp 'named nil) ; 8=name 11=proto 14=attr-start +;; cperl-maybe-white-and-comment-rex ; 15=pre-block + (set (make-local-variable 'defun-prompt-regexp) + (concat "^[ \t]*\\(" + cperl-sub-regexp + (cperl-after-sub-regexp 'named 'attr-groups) + "\\|" ; per toke.c + "\\(BEGIN\\|UNITCHECK\\|CHECK\\|INIT\\|END\\|AUTOLOAD\\|DESTROY\\)" + "\\)" + cperl-maybe-white-and-comment-rex)) + (set (make-local-variable 'comment-indent-function) #'cperl-comment-indent) (and (boundp 'fill-paragraph-function) - (progn - (make-local-variable 'fill-paragraph-function) - (set 'fill-paragraph-function 'cperl-fill-paragraph))) - (make-local-variable 'parse-sexp-ignore-comments) - (setq parse-sexp-ignore-comments t) - (make-local-variable 'indent-region-function) - (setq indent-region-function 'cperl-indent-region) - ;;(setq auto-fill-function 'cperl-do-auto-fill) ; Need to switch on and off! - (make-local-variable 'imenu-create-index-function) - (setq imenu-create-index-function - (function cperl-imenu--create-perl-index)) - (make-local-variable 'imenu-sort-function) - (setq imenu-sort-function nil) - (make-local-variable 'vc-rcs-header) - (set 'vc-rcs-header cperl-vc-rcs-header) - (make-local-variable 'vc-sccs-header) - (set 'vc-sccs-header cperl-vc-sccs-header) + (set (make-local-variable 'fill-paragraph-function) + #'cperl-fill-paragraph)) + (set (make-local-variable 'parse-sexp-ignore-comments) t) + (set (make-local-variable 'indent-region-function) #'cperl-indent-region) + ;;(setq auto-fill-function #'cperl-do-auto-fill) ; Need to switch on and off! + (set (make-local-variable 'imenu-create-index-function) + #'cperl-imenu--create-perl-index) + (set (make-local-variable 'imenu-sort-function) nil) + (set (make-local-variable 'vc-rcs-header) cperl-vc-rcs-header) + (set (make-local-variable 'vc-sccs-header) cperl-vc-sccs-header) (when (featurep 'xemacs) ;; This one is obsolete... - (make-local-variable 'vc-header-alist) - (set 'vc-header-alist (or cperl-vc-header-alist ; Avoid warning - `((SCCS ,(car cperl-vc-sccs-header)) - (RCS ,(car cperl-vc-rcs-header)))))) + (set (make-local-variable 'vc-header-alist) + (or cperl-vc-header-alist ; Avoid warning + `((SCCS ,(car cperl-vc-sccs-header)) + (RCS ,(car cperl-vc-rcs-header)))))) (cond ((boundp 'compilation-error-regexp-alist-alist);; xemacs 20.x - (make-local-variable 'compilation-error-regexp-alist-alist) - (set 'compilation-error-regexp-alist-alist + (set (make-local-variable 'compilation-error-regexp-alist-alist) (cons (cons 'cperl (car cperl-compilation-error-regexp-alist)) - (symbol-value 'compilation-error-regexp-alist-alist))) + compilation-error-regexp-alist-alist)) (if (fboundp 'compilation-build-compilation-error-regexp-alist) (let ((f 'compilation-build-compilation-error-regexp-alist)) (funcall f)) (make-local-variable 'compilation-error-regexp-alist) (push 'cperl compilation-error-regexp-alist))) ((boundp 'compilation-error-regexp-alist);; xemacs 19.x - (make-local-variable 'compilation-error-regexp-alist) - (set 'compilation-error-regexp-alist + (set (make-local-variable 'compilation-error-regexp-alist) (append cperl-compilation-error-regexp-alist - (symbol-value 'compilation-error-regexp-alist))))) - (make-local-variable 'font-lock-defaults) - (setq font-lock-defaults - (cond - ((string< emacs-version "19.30") - '(cperl-font-lock-keywords-2 nil nil ((?_ . "w")))) - ((string< emacs-version "19.33") ; Which one to use? - '((cperl-font-lock-keywords - cperl-font-lock-keywords-1 - cperl-font-lock-keywords-2) nil nil ((?_ . "w")))) - (t - '((cperl-load-font-lock-keywords - cperl-load-font-lock-keywords-1 - cperl-load-font-lock-keywords-2) nil nil ((?_ . "w")))))) - (make-local-variable 'cperl-syntax-state) - (setq cperl-syntax-state nil) ; reset syntaxification cache + compilation-error-regexp-alist)))) + (set (make-local-variable 'font-lock-defaults) + '((cperl-load-font-lock-keywords + cperl-load-font-lock-keywords-1 + cperl-load-font-lock-keywords-2) nil nil ((?_ . "w")))) + ;; Reset syntaxification cache. + (set (make-local-variable 'cperl-syntax-state) nil) (if cperl-use-syntax-table-text-property (if (eval-when-compile (fboundp 'syntax-propertize-rules)) (progn @@ -1834,21 +1763,19 @@ or as help on variables `cperl-tips', `cperl-problems', ;; to re-apply them. (setq cperl-syntax-done-to start) (cperl-fontify-syntaxically end)))) - (make-local-variable 'parse-sexp-lookup-properties) ;; Do not introduce variable if not needed, we check it! - (set 'parse-sexp-lookup-properties t) + (set (make-local-variable 'parse-sexp-lookup-properties) t) ;; Fix broken font-lock: (or (boundp 'font-lock-unfontify-region-function) - (set 'font-lock-unfontify-region-function - 'font-lock-default-unfontify-region)) + (setq font-lock-unfontify-region-function + #'font-lock-default-unfontify-region)) (unless (featurep 'xemacs) ; Our: just a plug for wrong font-lock - (make-local-variable 'font-lock-unfontify-region-function) - (set 'font-lock-unfontify-region-function ; not present with old Emacs - 'cperl-font-lock-unfontify-region-function)) - (make-local-variable 'cperl-syntax-done-to) - (setq cperl-syntax-done-to nil) ; reset syntaxification cache - (make-local-variable 'font-lock-syntactic-keywords) - (setq font-lock-syntactic-keywords + (set (make-local-variable 'font-lock-unfontify-region-function) + ;; not present with old Emacs + #'cperl-font-lock-unfontify-region-function)) + ;; Reset syntaxification cache. + (set (make-local-variable 'cperl-syntax-done-to) nil) + (set (make-local-variable 'font-lock-syntactic-keywords) (if cperl-syntaxify-by-font-lock '((cperl-fontify-syntaxically)) ;; unless font-lock-syntactic-keywords, font-lock (pre-22.1) @@ -1860,54 +1787,43 @@ or as help on variables `cperl-tips', `cperl-problems', (progn (setq cperl-font-lock-multiline t) ; Not localized... (set (make-local-variable 'font-lock-multiline) t)) - (make-local-variable 'font-lock-fontify-region-function) - (set 'font-lock-fontify-region-function ; not present with old Emacs - 'cperl-font-lock-fontify-region-function)) - (make-local-variable 'font-lock-fontify-region-function) - (set 'font-lock-fontify-region-function ; not present with old Emacs - 'cperl-font-lock-fontify-region-function) + (set (make-local-variable 'font-lock-fontify-region-function) + ;; not present with old Emacs + #'cperl-font-lock-fontify-region-function)) + (set (make-local-variable 'font-lock-fontify-region-function) + #'cperl-font-lock-fontify-region-function) (make-local-variable 'cperl-old-style) - (if (boundp 'normal-auto-fill-function) ; 19.33 and later - (set (make-local-variable 'normal-auto-fill-function) - 'cperl-do-auto-fill) - (or (fboundp 'cperl-old-auto-fill-mode) - (progn - (fset 'cperl-old-auto-fill-mode (symbol-function 'auto-fill-mode)) - (defun auto-fill-mode (&optional arg) - (interactive "P") - (eval '(cperl-old-auto-fill-mode arg)) ; Avoid a warning - (and auto-fill-function (memq major-mode '(perl-mode cperl-mode)) - (setq auto-fill-function 'cperl-do-auto-fill)))))) - (if (cperl-enable-font-lock) - (if (cperl-val 'cperl-font-lock) - (progn (or cperl-faces-init (cperl-init-faces)) - (font-lock-mode 1)))) + (set (make-local-variable 'normal-auto-fill-function) + #'cperl-do-auto-fill) + (if (cperl-val 'cperl-font-lock) + (progn (or cperl-faces-init (cperl-init-faces)) + (font-lock-mode 1))) (set (make-local-variable 'facemenu-add-face-function) - 'cperl-facemenu-add-face-function) ; XXXX What this guy is for??? + #'cperl-facemenu-add-face-function) ; XXXX What this guy is for??? (and (boundp 'msb-menu-cond) (not cperl-msb-fixed) (cperl-msb-fix)) (if (fboundp 'easy-menu-add) (easy-menu-add cperl-menu)) ; A NOP in Emacs. - (run-mode-hooks 'cperl-mode-hook) (if cperl-hook-after-change - (add-hook 'after-change-functions 'cperl-after-change-function nil t)) + (add-hook 'after-change-functions #'cperl-after-change-function nil t)) ;; After hooks since fontification will break this (if cperl-pod-here-scan (or cperl-syntaxify-by-font-lock (progn (or cperl-faces-init (cperl-init-faces-weak)) (cperl-find-pods-heres)))) ;; Setup Flymake - (add-hook 'flymake-diagnostic-functions 'perl-flymake nil t)) + (add-hook 'flymake-diagnostic-functions #'perl-flymake nil t)) ;; Fix for perldb - make default reasonable (defun cperl-db () (interactive) (require 'gud) + ;; FIXME: Use `read-string' or `read-shell-command'? (perldb (read-from-minibuffer "Run perldb (like this): " (if (consp gud-perldb-history) (car gud-perldb-history) - (concat "perl " + (concat "perl -d " (buffer-file-name))) nil nil '(gud-perldb-history . 1)))) @@ -1971,24 +1887,24 @@ or as help on variables `cperl-tips', `cperl-problems', (cperl-make-indent comment-column 1) ; Indent min 1 c))))) -;;;(defun cperl-comment-indent-fallback () -;;; "Is called if the standard comment-search procedure fails. -;;;Point is at start of real comment." -;;; (let ((c (current-column)) target cnt prevc) -;;; (if (= c comment-column) nil -;;; (setq cnt (skip-chars-backward "[ \t]")) -;;; (setq target (max (1+ (setq prevc -;;; (current-column))) ; Else indent at comment column -;;; comment-column)) -;;; (if (= c comment-column) nil -;;; (delete-backward-char cnt) -;;; (while (< prevc target) -;;; (insert "\t") -;;; (setq prevc (current-column))) -;;; (if (> prevc target) (progn (delete-char -1) (setq prevc (current-column)))) -;;; (while (< prevc target) -;;; (insert " ") -;;; (setq prevc (current-column))))))) +;;(defun cperl-comment-indent-fallback () +;; "Is called if the standard comment-search procedure fails. +;;Point is at start of real comment." +;; (let ((c (current-column)) target cnt prevc) +;; (if (= c comment-column) nil +;; (setq cnt (skip-chars-backward "[ \t]")) +;; (setq target (max (1+ (setq prevc +;; (current-column))) ; Else indent at comment column +;; comment-column)) +;; (if (= c comment-column) nil +;; (delete-backward-char cnt) +;; (while (< prevc target) +;; (insert "\t") +;; (setq prevc (current-column))) +;; (if (> prevc target) (progn (delete-char -1) (setq prevc (current-column)))) +;; (while (< prevc target) +;; (insert " ") +;; (setq prevc (current-column))))))) (defun cperl-indent-for-comment () "Substitute for `indent-for-comment' in CPerl." @@ -2024,7 +1940,7 @@ char is \"{\", insert extra newline before only if (interactive "P") (let (insertpos (other-end (if (and cperl-electric-parens-mark - (cperl-mark-active) + (region-active-p) (< (mark) (point))) (mark) nil))) @@ -2096,13 +2012,13 @@ char is \"{\", insert extra newline before only if (cperl-auto-newline cperl-auto-newline) (other-end (or end (if (and cperl-electric-parens-mark - (cperl-mark-active) + (region-active-p) (> (mark) (point))) (save-excursion (goto-char (mark)) (point-marker)) nil))) - pos after) + pos) (and (cperl-val 'cperl-electric-lbrace-space) (eq (preceding-char) ?$) (save-excursion @@ -2132,9 +2048,8 @@ char is \"{\", insert extra newline before only if "Insert an opening parenthesis or a matching pair of parentheses. See `cperl-electric-parens'." (interactive "P") - (let ((beg (point-at-bol)) - (other-end (if (and cperl-electric-parens-mark - (cperl-mark-active) + (let ((other-end (if (and cperl-electric-parens-mark + (region-active-p) (> (mark) (point))) (save-excursion (goto-char (mark)) @@ -2144,7 +2059,6 @@ See `cperl-electric-parens'." (memq last-command-event (append cperl-electric-parens-string nil)) (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point)) - ;;(not (save-excursion (search-backward "#" beg t))) (if (eq last-command-event ?<) (progn ;; This code is too electric, see Bug#3943. @@ -2169,12 +2083,11 @@ See `cperl-electric-parens'." If not, or if we are not at the end of marking range, would self-insert. Affected by `cperl-electric-parens'." (interactive "P") - (let ((beg (point-at-bol)) - (other-end (if (and cperl-electric-parens-mark + (let ((other-end (if (and cperl-electric-parens-mark (cperl-val 'cperl-electric-parens) (memq last-command-event (append cperl-electric-parens-string nil)) - (cperl-mark-active) + (region-active-p) (< (mark) (point))) (mark) nil)) @@ -2183,7 +2096,6 @@ Affected by `cperl-electric-parens'." (cperl-val 'cperl-electric-parens) (memq last-command-event '( ?\) ?\] ?\} ?\> )) (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point)) - ;;(not (save-excursion (search-backward "#" beg t))) ) (progn (self-insert-command (prefix-numeric-value arg)) @@ -2223,6 +2135,7 @@ to nil." (save-excursion (or (not (re-search-backward "^=" nil t)) (or (looking-at "=cut") + (looking-at "=end") (and cperl-use-syntax-table-text-property (not (eq (get-text-property (point) 'syntax-type) @@ -2297,7 +2210,7 @@ to nil." (get-text-property (point) 'in-pod) (cperl-after-expr-p nil "{;:") (and (re-search-backward "\\(\\`\n?\\|^\n\\)=\\sw+" (point-min) t) - (not (looking-at "\n*=cut")) + (not (or (looking-at "\n*=cut") (looking-at "\n*=end"))) (or (not cperl-use-syntax-table-text-property) (eq (get-text-property (point) 'syntax-type) 'pod)))))) (progn @@ -2316,7 +2229,7 @@ to nil." nil t)))) ; Only one (progn (forward-word-strictly 1) - (setq name (file-name-base) + (setq name (file-name-base (buffer-file-name)) p (point)) (insert " NAME\n\n" name " - \n\n=head1 SYNOPSIS\n\n\n\n" @@ -2355,6 +2268,7 @@ to nil." beg t))) (save-excursion (or (not (re-search-backward "^=" nil t)) (looking-at "=cut") + (looking-at "=end") (and cperl-use-syntax-table-text-property (not (eq (get-text-property (point) 'syntax-type) @@ -2454,7 +2368,7 @@ If in POD, insert appropriate lines." ;; We are after \n now, so look for the rest (if (looking-at "\\(\\`\n?\\|\n\\)=\\sw+") (progn - (setq cut (looking-at "\\(\\`\n?\\|\n\\)=cut\\>")) + (setq cut (looking-at "\\(\\`\n?\\|\n\\)=\\(cut\\|end\\)\\>")) (setq over (looking-at "\\(\\`\n?\\|\n\\)=over\\>")) t))) (if (and over @@ -2622,11 +2536,10 @@ The relative indentation among the lines of the expression are preserved." Return the amount the indentation changed by." (let ((case-fold-search nil) (pos (- (point-max) (point))) - indent i beg shift-amt) + indent i shift-amt) (setq indent (cperl-calculate-indent parse-data) i indent) (beginning-of-line) - (setq beg (point)) (cond ((or (eq indent nil) (eq indent t)) (setq indent (current-indentation) i nil)) ;;((eq indent t) ; Never? @@ -2653,8 +2566,8 @@ Return the amount the indentation changed by." (zerop shift-amt)) (if (> (- (point-max) pos) (point)) (goto-char (- (point-max) pos))) - ;;;(delete-region beg (point)) - ;;;(indent-to indent) + ;;(delete-region beg (point)) + ;;(indent-to indent) (cperl-make-indent indent) ;; If initial point was within line's indentation, ;; position after the indentation. Else stay at same point in text. @@ -2672,13 +2585,13 @@ Return the amount the indentation changed by." (looking-at "[a-zA-Z_][a-zA-Z0-9_]*:[^:]")))) (defun cperl-get-state (&optional parse-start start-state) - ;; returns list (START STATE DEPTH PRESTART), - ;; START is a good place to start parsing, or equal to - ;; PARSE-START if preset, - ;; STATE is what is returned by `parse-partial-sexp'. - ;; DEPTH is true is we are immediately after end of block - ;; which contains START. - ;; PRESTART is the position basing on which START was found. + "Return list (START STATE DEPTH PRESTART), +START is a good place to start parsing, or equal to +PARSE-START if preset, +STATE is what is returned by `parse-partial-sexp'. +DEPTH is true is we are immediately after end of block +which contains START. +PRESTART is the position basing on which START was found." (save-excursion (let ((start-point (point)) depth state start prestart) (if (and parse-start @@ -2707,17 +2620,17 @@ Return the amount the indentation changed by." (defun cperl-beginning-of-property (p prop &optional lim) "Given that P has a property PROP, find where the property starts. Will not look before LIM." - ;;; XXXX What to do at point-max??? +;;; XXXX What to do at point-max??? (or (previous-single-property-change (cperl-1+ p) prop lim) (point-min)) -;;; (cond ((eq p (point-min)) -;;; p) -;;; ((and lim (<= p lim)) -;;; p) -;;; ((not (get-text-property (1- p) prop)) -;;; p) -;;; (t (or (previous-single-property-change p look-prop lim) -;;; (point-min)))) + ;; (cond ((eq p (point-min)) + ;; p) + ;; ((and lim (<= p lim)) + ;; p) + ;; ((not (get-text-property (1- p) prop)) + ;; p) + ;; (t (or (previous-single-property-change p look-prop lim) + ;; (point-min)))) ) (defun cperl-sniff-for-indent (&optional parse-data) ; was parse-start @@ -2887,6 +2800,8 @@ Will not look before LIM." (cperl-backward-to-noncomment containing-sexp)) ;; Now we get non-label preceding the indent point (if (not (or (eq (1- (point)) containing-sexp) + (and cperl-indent-parens-as-block + (not is-block)) (memq (preceding-char) (append (if is-block " ;{" " ,;{") '(nil))) (and (eq (preceding-char) ?\}) @@ -2962,12 +2877,13 @@ Will not look before LIM." ;; first thing on the line, say in the case of ;; anonymous sub in a hash. (if (and;; Is it a sub in group starting on this line? + cperl-indent-subs-specially (cond ((get-text-property (point) 'attrib-group) (goto-char (cperl-beginning-of-property (point) 'attrib-group))) ((eq (preceding-char) ?b) (forward-sexp -1) - (looking-at "sub\\>"))) + (looking-at (concat cperl-sub-regexp "\\>")))) (setq p (nth 1 ; start of innermost containing list (parse-partial-sexp (point-at-bol) @@ -3001,7 +2917,10 @@ Will not look before LIM." "Alist of indentation rules for CPerl mode. The values mean: nil: do not indent; - number: add this amount of indentation.") + FUNCTION: a function to compute the indentation to use. + Takes a single argument which provides the currently computed indentation + context, and should return the column to which to indent. + NUMBER: add this amount of indentation.") (defun cperl-calculate-indent (&optional parse-data) ; was parse-start "Return appropriate indentation for current line as Perl code. @@ -3020,7 +2939,11 @@ and closing parentheses and brackets." ((vectorp i) (setq what (assoc (elt i 0) cperl-indent-rules-alist)) (cond - (what (cadr what)) ; Load from table + (what + (let ((action (cadr what))) + (cond ((functionp action) (apply action (list i parse-data))) + ((numberp action) (+ action (current-indentation))) + (t action)))) ;; ;; Indenters for regular expressions with //x and qw() ;; @@ -3184,7 +3107,7 @@ and closing parentheses and brackets." (defun cperl-calculate-indent-within-comment () "Return the indentation amount for line, assuming that the current line is to be regarded as part of a block comment." - (let (end star-start) + (let (end) (save-excursion (beginning-of-line) (skip-chars-forward " \t") @@ -3442,8 +3365,8 @@ Works before syntax recognition is done." (or now (put-text-property b e 'cperl-postpone (cons type val))) (put-text-property b e type val))) -;;; Here is how the global structures (those which cannot be -;;; recognized locally) are marked: +;; Here is how the global structures (those which cannot be +;; recognized locally) are marked: ;; a) PODs: ;; Start-to-end is marked `in-pod' ==> t ;; Each non-literal part is marked `syntax-type' ==> `pod' @@ -3463,17 +3386,16 @@ Works before syntax recognition is done." ;; (or 0 if declaration); up to `{' or ';': `syntax-type' => `sub-decl'. ;; f) Multiline my/our declaration lists etc: `syntax-type' => `multiline' -;;; In addition, some parts of RExes may be marked as `REx-interpolated' -;;; (value: 0 in //o, 1 if "interpolated variable" is whole-REx, t otherwise). +;; In addition, some parts of RExes may be marked as `REx-interpolated' +;; (value: 0 in //o, 1 if "interpolated variable" is whole-REx, t otherwise). (defun cperl-unwind-to-safe (before &optional end) ;; if BEFORE, go to the previous start-of-line on each step of unwinding - (let ((pos (point)) opos) + (let ((pos (point))) (while (and pos (progn (beginning-of-line) (get-text-property (setq pos (point)) 'syntax-type))) - (setq opos pos - pos (cperl-beginning-of-property pos 'syntax-type)) + (setq pos (cperl-beginning-of-property pos 'syntax-type)) (if (eq pos (point-min)) (setq pos nil)) (if pos @@ -3502,7 +3424,7 @@ Works before syntax recognition is done." (setq end (point))))) (or end pos))))) -;;; These are needed for byte-compile (at least with v19) +;; These are needed for byte-compile (at least with v19) (defvar cperl-nonoverridable-face) (defvar font-lock-variable-name-face) (defvar font-lock-function-name-face) @@ -3517,7 +3439,7 @@ Works before syntax recognition is done." Should be called with the point before leading colon of an attribute." ;; Works *before* syntax recognition is done (or st-l (setq st-l (list nil))) ; Avoid overwriting '() - (let (st b p reset-st after-first (start (point)) start1 end1) + (let (st p reset-st after-first (start (point)) start1 end1) (condition-case b (while (looking-at (concat @@ -3618,7 +3540,8 @@ Should be called with the point before leading colon of an attribute." 'face dashface)) ;; save match data (for looking-at) (setq lll (mapcar (function (lambda (elt) (cons (match-beginning elt) - (match-end elt)))) l)) + (match-end elt)))) + l)) (while lll (setq ll (car lll)) (setq lle (cdr ll) @@ -3636,7 +3559,7 @@ Should be called with the point before leading colon of an attribute." (goto-char endbracket) ; just in case something misbehaves??? t)) -;;; Debugging this may require (setq max-specpdl-size 2000)... +;; Debugging this may require (setq max-specpdl-size 2000)... (defun cperl-find-pods-heres (&optional min max non-inter end ignore-max end-of-here-doc) "Scans the buffer for hard-to-parse Perl constructions. If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify @@ -3746,7 +3669,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', "\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob> "\\|" ;; 1+6+2+1+1=11 extra () before this - "\\<sub\\>" ; sub with proto/attr + "\\<" cperl-sub-regexp "\\>" ; sub with proto/attr "\\(" cperl-white-and-comment-rex "\\(::[a-zA-Z_:'0-9]*\\|[a-zA-Z_'][a-zA-Z_:'0-9]*\\)\\)?" ; name @@ -3759,7 +3682,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', "\\|" ;; 1+6+2+1+1+6+1=18 extra () before this (old pack'var syntax; ;; we do not support intervening comments...): - "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'" + "\\(\\<" cperl-sub-regexp "[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'" ;; 1+6+2+1+1+6+1+1=19 extra () before this: "\\|" "__\\(END\\|DATA\\)__" ; __END__ or __DATA__ @@ -3834,7 +3757,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', state-point b nil nil state) state-point b) (if (or (nth 3 state) (nth 4 state) - (looking-at "cut\\>")) + (looking-at "\\(cut\\|\\end\\)\\>")) (if (or (nth 3 state) (nth 4 state) ignore-max) nil ; Doing a chunk only (message "=cut is not preceded by a POD section") @@ -3847,10 +3770,10 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', b1 nil) ; error condition ;; We do not search to max, since we may be called from ;; some hook of fontification, and max is random - (or (re-search-forward "^\n=cut\\>" stop-point 'toend) + (or (re-search-forward "^\n=\\(cut\\|\\end\\)\\>" stop-point 'toend) (progn (goto-char b) - (if (re-search-forward "\n=cut\\>" stop-point 'toend) + (if (re-search-forward "\n=\\(cut\\|\\end\\)\\>" stop-point 'toend) (progn (message "=cut is not preceded by an empty line") (setq b1 t) @@ -3957,7 +3880,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (progn (forward-sexp -2) (not - (looking-at "\\(printf?\\|system\\|exec\\|sort\\)\\>"))) + (looking-at "\\(printf?\\|say\\|system\\|exec\\|sort\\)\\>"))) (error t))))))) (error nil))) ; func(<<EOF) (and (not (match-beginning 6)) ; Empty @@ -4141,7 +4064,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (not (memq (preceding-char) '(?$ ?@ ?& ?%))) (looking-at - "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\)\\>"))))) + "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\|say\\)\\>"))))) (and (eq (preceding-char) ?.) (eq (char-after (- (point) 2)) ?.)) (bobp)) @@ -4539,7 +4462,7 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (setq REx-subgr-end qtag) ;End smart-highlighted ;; Apparently, I can't put \] into a charclass ;; in m]]: m][\\\]\]] produces [\\]] -;;; POSIX? [:word:] [:^word:] only inside [] +;;; POSIX? [:word:] [:^word:] only inside [] ;;; "\\=\\(\\\\.\\|[^][\\\\]\\|\\[:\\^?\sw+:]\\|\\[[^:]\\)*]") (while ; look for unescaped ] (and argument @@ -4797,8 +4720,8 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (setq stop t)))))) ;; Used only in `cperl-calculate-indent'... -(defun cperl-block-p () ; Do not C-M-q ! One string contains ";" ! - ;; Positions is before ?\{. Checks whether it starts a block. +(defun cperl-block-p () + "Point is before ?\\{. Checks whether it starts a block." ;; No save-excursion! This is more a distinguisher of a block/hash ref... (cperl-backward-to-noncomment (point-min)) (or (memq (preceding-char) (append ";){}$@&%\C-@" nil)) ; Or label! \C-@ at bobp @@ -4817,14 +4740,14 @@ the sections using `cperl-pod-head-face', `cperl-pod-face', (and (eq (preceding-char) ?b) (progn (forward-sexp -1) - (looking-at "sub[ \t\n\f#]"))))))))) - -;;; What is the difference of (cperl-after-block-p lim t) and (cperl-block-p)? -;;; No save-excursion; condition-case ... In (cperl-block-p) the block -;;; may be a part of an in-statement construct, such as -;;; ${something()}, print {FH} $data. -;;; Moreover, one takes positive approach (looks for else,grep etc) -;;; another negative (looks for bless,tr etc) + (looking-at (concat cperl-sub-regexp "[ \t\n\f#]")))))))))) + +;; What is the difference of (cperl-after-block-p lim t) and (cperl-block-p)? +;; No save-excursion; condition-case ... In (cperl-block-p) the block +;; may be a part of an in-statement construct, such as +;; ${something()}, print {FH} $data. +;; Moreover, one takes positive approach (looks for else,grep etc) +;; another negative (looks for bless,tr etc) (defun cperl-after-block-p (lim &optional pre-block) "Return true if the preceding } (if PRE-BLOCK, following {) delimits a block. Would not look before LIM. Assumes that LIM is a good place to begin a @@ -4846,15 +4769,16 @@ statement would start; thus the block in ${func()} does not count." (save-excursion (forward-sexp -1) ;; else {} but not else::func {} - (or (and (looking-at "\\(else\\|continue\\|grep\\|map\\|BEGIN\\|END\\|CHECK\\|INIT\\)\\>") + (or (and (looking-at "\\(else\\|catch\\|try\\|continue\\|grep\\|map\\|BEGIN\\|END\\|UNITCHECK\\|CHECK\\|INIT\\)\\>") (not (looking-at "\\(\\sw\\|_\\)+::"))) ;; sub f {} (progn (cperl-backward-to-noncomment lim) - (and (eq (preceding-char) ?b) + (and (cperl-char-ends-sub-keyword-p (preceding-char)) (progn (forward-sexp -1) - (looking-at "sub[ \t\n\f#]")))))) + (looking-at + (concat cperl-sub-regexp "[ \t\n\f#]"))))))) ;; What precedes is not word... XXXX Last statement in sub??? (cperl-after-expr-p lim)))) (error nil)))) @@ -4865,7 +4789,7 @@ TEST is the expression to evaluate at the found position. If absent, CHARS is a string that contains good characters to have before us (however, `}' is treated \"smartly\" if it is not in the list)." (let ((lim (or lim (point-min))) - stop p pr) + stop p) (cperl-update-syntaxification (point) (point)) (save-excursion (while (and (not stop) (> (point) lim)) @@ -4940,7 +4864,6 @@ CHARS is a string that contains good characters to have before us (however, (error t)))) (defun cperl-forward-to-end-of-expr (&optional lim) - (let ((p (point)))) (condition-case nil (progn (while (and (< (point) (or lim (point-max))) @@ -4970,7 +4893,7 @@ CHARS is a string that contains good characters to have before us (however, (forward-sexp -1) (not (looking-at - "\\(map\\|grep\\|printf?\\|system\\|exec\\|tr\\|s\\)\\>"))))))) + "\\(map\\|grep\\|say\\|printf?\\|system\\|exec\\|tr\\|s\\)\\>"))))))) (defun cperl-indent-exp () @@ -5006,13 +4929,13 @@ conditional/loop constructs." (if (eq (following-char) ?$ ) ; for my $var (list) (progn (forward-sexp -1) - (if (looking-at "\\(my\\|local\\|our\\)\\>") + (if (looking-at "\\(state\\|my\\|local\\|our\\)\\>") (forward-sexp -1)))) (if (looking-at (concat "\\(\\elsif\\|if\\|unless\\|while\\|until" "\\|for\\(each\\)?\\>\\(\\(" cperl-maybe-white-and-comment-rex - "\\(my\\|local\\|our\\)\\)?" + "\\(state\\|my\\|local\\|our\\)\\)?" cperl-maybe-white-and-comment-rex "\\$[_a-zA-Z0-9]+\\)?\\)\\>")) (progn @@ -5097,7 +5020,7 @@ Returns some position at the last line." ;; Looking at: ;; foreach my $var (if (looking-at - "[ \t]*\\<for\\(each\\)?[ \t]+\\(my\\|local\\|our\\)\\(\t*\\|[ \t][ \t]+\\)[^ \t\n]") + "[ \t]*\\<for\\(each\\)?[ \t]+\\(state\\|my\\|local\\|our\\)\\(\t*\\|[ \t][ \t]+\\)[^ \t\n]") (progn (forward-word-strictly 2) (delete-horizontal-space) @@ -5106,7 +5029,7 @@ Returns some position at the last line." ;; Looking at: ;; foreach my $var ( (if (looking-at - "[ \t]*\\<for\\(each\\)?[ \t]+\\(my\\|local\\|our\\)[ \t]*\\$[_a-zA-Z0-9]+\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]") + "[ \t]*\\<for\\(each\\)?[ \t]+\\(state\\|my\\|local\\|our\\)[ \t]*\\$[_a-zA-Z0-9]+\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]") (progn (forward-sexp 3) (delete-horizontal-space) @@ -5116,7 +5039,7 @@ Returns some position at the last line." ;; Looking at (with or without "}" at start, ending after "({"): ;; } foreach my $var () OR { (if (looking-at - "[ \t]*\\(}[ \t]*\\)?\\<\\(\\els\\(e\\|if\\)\\|continue\\|if\\|unless\\|while\\|for\\(each\\)?\\(\\([ \t]+\\(my\\|local\\|our\\)\\)?[ \t]*\\$[_a-zA-Z0-9]+\\)?\\|until\\)\\>\\([ \t]*(\\|[ \t\n]*{\\)\\|[ \t]*{") + "[ \t]*\\(}[ \t]*\\)?\\<\\(\\els\\(e\\|if\\)\\|continue\\|if\\|unless\\|while\\|for\\(each\\)?\\(\\([ \t]+\\(state\\|my\\|local\\|our\\)\\)?[ \t]*\\$[_a-zA-Z0-9]+\\)?\\|until\\)\\>\\([ \t]*(\\|[ \t\n]*{\\)\\|[ \t]*{") (progn (setq ml (match-beginning 8)) ; "(" or "{" after control word (re-search-forward "[({]") @@ -5237,7 +5160,7 @@ Returns some position at the last line." (defvar cperl-update-start) ; Do not need to make them local (defvar cperl-update-end) -(defun cperl-delay-update-hook (beg end old-len) +(defun cperl-delay-update-hook (beg end _old-len) (setq cperl-update-start (min beg (or cperl-update-start (point-max)))) (setq cperl-update-end (max end (or cperl-update-end (point-min))))) @@ -5254,13 +5177,11 @@ conditional/loop constructs." (cperl-update-syntaxification end end) (save-excursion (let (cperl-update-start cperl-update-end (h-a-c after-change-functions)) - (let ((indent-info (if cperl-emacs-can-parse - (list nil nil nil) ; Cannot use '(), since will modify - nil)) - (pm 0) + (let ((indent-info (list nil nil nil) ; Cannot use '(), since will modify + ) after-change-functions ; Speed it up! - st comm old-comm-indent new-comm-indent p pp i empty) - (if h-a-c (add-hook 'after-change-functions 'cperl-delay-update-hook)) + comm old-comm-indent new-comm-indent i empty) + (if h-a-c (add-hook 'after-change-functions #'cperl-delay-update-hook)) (goto-char start) (setq old-comm-indent (and (cperl-to-comment-or-eol) (current-column)) @@ -5269,7 +5190,6 @@ conditional/loop constructs." (setq end (set-marker (make-marker) end)) ; indentation changes pos (or (bolp) (beginning-of-line 2)) (while (and (<= (point) end) (not (eobp))) ; bol to check start - (setq st (point)) (if (or (setq empty (looking-at "[ \t]*\n")) (and (setq comm (looking-at "[ \t]*#")) @@ -5455,10 +5375,10 @@ indentation and initial hashes. Behaves usually outside of comment." (defun cperl-imenu--create-perl-index (&optional regexp) (require 'imenu) ; May be called from TAGS creator (let ((index-alist '()) (index-pack-alist '()) (index-pod-alist '()) - (index-unsorted-alist '()) (i-s-f (default-value 'imenu-sort-function)) + (index-unsorted-alist '()) (index-meth-alist '()) meth packages ends-ranges p marker is-proto - (prev-pos 0) is-pack index index1 name (end-range 0) package) + is-pack index index1 name (end-range 0) package) (goto-char (point-min)) (cperl-update-syntaxification (point-max) (point-max)) ;; Search for the function @@ -5604,7 +5524,7 @@ indentation and initial hashes. Behaves usually outside of comment." (defun cperl-outline-level () (looking-at outline-regexp) (cond ((not (match-beginning 1)) 0) ; beginning-of-file -;;;; 2=package-group, 5=package-name 8=sub-name 16=head-level + ;; 2=package-group, 5=package-name 8=sub-name 16=head-level ((match-beginning 2) 0) ; package ((match-beginning 8) 1) ; sub ((match-beginning 16) @@ -5627,10 +5547,9 @@ indentation and initial hashes. Behaves usually outside of comment." (if (memq major-mode '(perl-mode cperl-mode)) (progn (or cperl-faces-init (cperl-init-faces))))))) - (if (fboundp 'eval-after-load) - (eval-after-load - "ps-print" - '(or cperl-faces-init (cperl-init-faces))))))) + (eval-after-load + "ps-print" + '(or cperl-faces-init (cperl-init-faces)))))) (defvar cperl-font-lock-keywords-1 nil "Additional expressions to highlight in Perl mode. Minimal set.") @@ -5679,12 +5598,21 @@ indentation and initial hashes. Behaves usually outside of comment." (cons (concat "\\(^\\|[^$@%&\\]\\)\\<\\(" + ;; FIXME: Use regexp-opt. (mapconcat - 'identity - '("if" "until" "while" "elsif" "else" "unless" "for" + #'identity + (append + cperl-sub-keywords + '("if" "until" "while" "elsif" "else" + "given" "when" "default" "break" + "unless" "for" + "try" "catch" "finally" "foreach" "continue" "exit" "die" "last" "goto" "next" - "redo" "return" "local" "exec" "sub" "do" "dump" "use" "our" - "require" "package" "eval" "my" "BEGIN" "END" "CHECK" "INIT") + "redo" "return" "local" "exec" + "do" "dump" + "use" "our" + "require" "package" "eval" "evalbytes" "my" "state" + "BEGIN" "END" "CHECK" "INIT" "UNITCHECK")) "\\|") ; Flow control "\\)\\>") 2) ; was "\\)[ \n\t;():,|&]" ; In what follows we use `type' style @@ -5692,13 +5620,14 @@ indentation and initial hashes. Behaves usually outside of comment." (list (concat "\\(^\\|[^$@%&\\]\\)\\<\\(" - ;; "CORE" "__FILE__" "__LINE__" "abs" "accept" "alarm" + ;; FIXME: Use regexp-opt. + ;; "CORE" "__FILE__" "__LINE__" "__SUB__" "abs" "accept" "alarm" ;; "and" "atan2" "bind" "binmode" "bless" "caller" ;; "chdir" "chmod" "chown" "chr" "chroot" "close" ;; "closedir" "cmp" "connect" "continue" "cos" "crypt" ;; "dbmclose" "dbmopen" "die" "dump" "endgrent" ;; "endhostent" "endnetent" "endprotoent" "endpwent" - ;; "endservent" "eof" "eq" "exec" "exit" "exp" "fcntl" + ;; "endservent" "eof" "eq" "exec" "exit" "exp" "fc" "fcntl" ;; "fileno" "flock" "fork" "formline" "ge" "getc" ;; "getgrent" "getgrgid" "getgrnam" "gethostbyaddr" ;; "gethostbyname" "gethostent" "getlogin" @@ -5721,7 +5650,7 @@ indentation and initial hashes. Behaves usually outside of comment." ;; "setsockopt" "shmctl" "shmget" "shmread" "shmwrite" ;; "shutdown" "sin" "sleep" "socket" "socketpair" ;; "sprintf" "sqrt" "srand" "stat" "substr" "symlink" - ;; "syscall" "sysopen" "sysread" "system" "syswrite" "tell" + ;; "syscall" "sysopen" "sysread" "sysseek" "system" "syswrite" "tell" ;; "telldir" "time" "times" "truncate" "uc" "ucfirst" ;; "umask" "unlink" "unpack" "utime" "values" "vec" ;; "wait" "waitpid" "wantarray" "warn" "write" "x" "xor" @@ -5732,7 +5661,7 @@ indentation and initial hashes. Behaves usually outside of comment." "CORE\\|d\\(ie\\|bm\\(close\\|open\\)\\|ump\\)\\|" "e\\(x\\(p\\|it\\|ec\\)\\|q\\|nd\\(p\\(rotoent\\|went\\)\\|" "hostent\\|servent\\|netent\\|grent\\)\\|of\\)\\|" - "f\\(ileno\\|cntl\\|lock\\|or\\(k\\|mline\\)\\)\\|" + "f\\(ileno\\|c\\(ntl\\)?\\|lock\\|or\\(k\\|mline\\)\\)\\|" "g\\(t\\|lob\\|mtime\\|e\\(\\|t\\(p\\(pid\\|r\\(iority\\|" "oto\\(byn\\(ame\\|umber\\)\\|ent\\)\\)\\|eername\\|w" "\\(uid\\|ent\\|nam\\)\\|grp\\)\\|host\\(by\\(addr\\|name\\)\\|" @@ -5750,12 +5679,12 @@ indentation and initial hashes. Behaves usually outside of comment." "\\(iority\\|otoent\\)\\|went\\|grp\\)\\|hostent\\|s\\(ervent\\|" "ockopt\\)\\|netent\\|grent\\)\\|ek\\(\\|dir\\)\\|lect\\|" "m\\(ctl\\|op\\|get\\)\\|nd\\)\\|h\\(utdown\\|m\\(read\\|ctl\\|" - "write\\|get\\)\\)\\|y\\(s\\(read\\|call\\|open\\|tem\\|write\\)\\|" + "write\\|get\\)\\)\\|y\\(s\\(read\\|call\\|open\\|tem\\|write\\|seek\\)\\|" "mlink\\)\\|in\\|leep\\|ocket\\(pair\\|\\)\\)\\|t\\(runcate\\|" "ell\\(\\|dir\\)\\|ime\\(\\|s\\)\\)\\|u\\(c\\(\\|first\\)\\|" "time\\|mask\\|n\\(pack\\|link\\)\\)\\|v\\(alues\\|ec\\)\\|" "w\\(a\\(rn\\|it\\(pid\\|\\)\\|ntarray\\)\\|rite\\)\\|" - "x\\(\\|or\\)\\|__\\(FILE__\\|LINE__\\|PACKAGE__\\)" + "x\\(\\|or\\)\\|__\\(FILE\\|LINE\\|PACKAGE\\|SUB\\)__" "\\)\\>") 2 'font-lock-type-face) ;; In what follows we use `other' style ;; for nonoverwritable builtins @@ -5763,27 +5692,28 @@ indentation and initial hashes. Behaves usually outside of comment." (list (concat "\\(^\\|[^$@%&\\]\\)\\<\\(" - ;; "AUTOLOAD" "BEGIN" "CHECK" "DESTROY" "END" "INIT" "__END__" "chomp" - ;; "chop" "defined" "delete" "do" "each" "else" "elsif" - ;; "eval" "exists" "for" "foreach" "format" "goto" + ;; "AUTOLOAD" "BEGIN" "CHECK" "DESTROY" "END" "INIT" "UNITCHECK" "__END__" "chomp" + ;; "break" "chop" "default" "defined" "delete" "do" "each" "else" "elsif" + ;; "eval" "evalbytes" "exists" "for" "foreach" "format" "given" "goto" ;; "grep" "if" "keys" "last" "local" "map" "my" "next" - ;; "no" "our" "package" "pop" "pos" "print" "printf" "push" - ;; "q" "qq" "qw" "qx" "redo" "return" "scalar" "shift" - ;; "sort" "splice" "split" "study" "sub" "tie" "tr" + ;; "no" "our" "package" "pop" "pos" "print" "printf" "prototype" "push" + ;; "q" "qq" "qw" "qx" "redo" "return" "say" "scalar" "shift" + ;; "sort" "splice" "split" "state" "study" "sub" "tie" "tr" ;; "undef" "unless" "unshift" "untie" "until" "use" - ;; "while" "y" - "AUTOLOAD\\|BEGIN\\|CHECK\\|cho\\(p\\|mp\\)\\|d\\(e\\(fined\\|lete\\)\\|" - "o\\)\\|DESTROY\\|e\\(ach\\|val\\|xists\\|ls\\(e\\|if\\)\\)\\|" - "END\\|for\\(\\|each\\|mat\\)\\|g\\(rep\\|oto\\)\\|INIT\\|if\\|keys\\|" + ;; "when" "while" "y" + "AUTOLOAD\\|BEGIN\\|\\(UNIT\\)?CHECK\\|break\\|c\\(atch\\|ho\\(p\\|mp\\)\\)\\|d\\(e\\(f\\(inally\\|ault\\|ined\\)\\|lete\\)\\|" + "o\\)\\|DESTROY\\|e\\(ach\\|val\\(bytes\\)?\\|xists\\|ls\\(e\\|if\\)\\)\\|" + "END\\|for\\(\\|each\\|mat\\)\\|g\\(iven\\|rep\\|oto\\)\\|INIT\\|if\\|keys\\|" "l\\(ast\\|ocal\\)\\|m\\(ap\\|y\\)\\|n\\(ext\\|o\\)\\|our\\|" - "p\\(ackage\\|rint\\(\\|f\\)\\|ush\\|o\\(p\\|s\\)\\)\\|" - "q\\(\\|q\\|w\\|x\\|r\\)\\|re\\(turn\\|do\\)\\|s\\(pli\\(ce\\|t\\)\\|" - "calar\\|tudy\\|ub\\|hift\\|ort\\)\\|t\\(r\\|ie\\)\\|" + "p\\(ackage\\|rototype\\|rint\\(\\|f\\)\\|ush\\|o\\(p\\|s\\)\\)\\|" + "q\\(\\|q\\|w\\|x\\|r\\)\\|re\\(turn\\|do\\)\\|s\\(ay\\|pli\\(ce\\|t\\)\\|" + "calar\\|t\\(ate\\|udy\\)\\|ub\\|hift\\|ort\\)\\|t\\(ry?\\|ied?\\)\\|" "u\\(se\\|n\\(shift\\|ti\\(l\\|e\\)\\|def\\|less\\)\\)\\|" - "while\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually + "wh\\(en\\|ile\\)\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually "\\|[sm]" ; Added manually - "\\)\\>") 2 'cperl-nonoverridable-face) - ;; (mapconcat 'identity + "\\)\\>") + 2 'cperl-nonoverridable-face) + ;; (mapconcat #'identity ;; '("#endif" "#else" "#ifdef" "#ifndef" "#if" ;; "#include" "#define" "#undef") ;; "\\|") @@ -5792,7 +5722,7 @@ indentation and initial hashes. Behaves usually outside of comment." ;; This highlights declarations and definitions differently. ;; We do not try to highlight in the case of attributes: ;; it is already done by `cperl-find-pods-heres' - (list (concat "\\<sub" + (list (concat "\\<" cperl-sub-regexp cperl-white-and-comment-rex ; whitespace/comments "\\([^ \n\t{;()]+\\)" ; 2=name (assume non-anonymous) "\\(" @@ -5834,14 +5764,14 @@ indentation and initial hashes. Behaves usually outside of comment." font-lock-string-face t) '("^[ \t]*\\([a-zA-Z0-9_]+[ \t]*:\\)[ \t]*\\($\\|{\\|\\<\\(until\\|while\\|for\\(each\\)?\\|do\\)\\>\\)" 1 font-lock-constant-face) ; labels - '("\\<\\(continue\\|next\\|last\\|redo\\|goto\\)\\>[ \t]+\\([a-zA-Z0-9_:]+\\)" ; labels as targets + '("\\<\\(continue\\|next\\|last\\|redo\\|break\\|goto\\)\\>[ \t]+\\([a-zA-Z0-9_:]+\\)" ; labels as targets 2 font-lock-constant-face) ;; Uncomment to get perl-mode-like vars ;;; '("[$*]{?\\(\\sw+\\)" 1 font-lock-variable-name-face) ;;; '("\\([@%]\\|\\$#\\)\\(\\sw+\\)" ;;; (2 (cons font-lock-variable-name-face '(underline)))) (cond ((featurep 'font-lock-extra) - '("^[ \t]*\\(my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?" + '("^[ \t]*\\(state\\|my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?" (3 font-lock-variable-name-face) (4 '(another 4 nil ("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?" @@ -5850,7 +5780,7 @@ indentation and initial hashes. Behaves usually outside of comment." nil t))) ; local variables, multiple (font-lock-anchored ;; 1=my_etc, 2=white? 3=(+white? 4=white? 5=var - `(,(concat "\\<\\(my\\|local\\|our\\)" + `(,(concat "\\<\\(state\\|my\\|local\\|our\\)" cperl-maybe-white-and-comment-rex "\\((" cperl-maybe-white-and-comment-rex @@ -5898,54 +5828,47 @@ indentation and initial hashes. Behaves usually outside of comment." 'syntax-type 'multiline)) (setq cperl-font-lock-multiline-start nil))) (3 font-lock-variable-name-face)))) - (t '("^[ \t{}]*\\(my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" + (t '("^[ \t{}]*\\(state\\|my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" 3 font-lock-variable-name-face))) - '("\\<for\\(each\\)?\\([ \t]+\\(my\\|local\\|our\\)\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*(" + '("\\<for\\(each\\)?\\([ \t]+\\(state\\|my\\|local\\|our\\)\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*(" 4 font-lock-variable-name-face) ;; Avoid $!, and s!!, qq!! etc. when not fontifying syntactically '("\\(?:^\\|[^smywqrx$]\\)\\(!\\)" 1 font-lock-negation-char-face) '("\\[\\(\\^\\)" 1 font-lock-negation-char-face prepend))) (setq t-font-lock-keywords-1 - (and (fboundp 'turn-on-font-lock) ; Check for newer font-lock - ;; not yet as of XEmacs 19.12, works with 21.1.11 - (or - (not (featurep 'xemacs)) - (string< "21.1.9" emacs-version) - (and (string< "21.1.10" emacs-version) - (string< emacs-version "21.1.2"))) - '( - ("\\(\\([@%]\\|\\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1 - (if (eq (char-after (match-beginning 2)) ?%) - 'cperl-hash-face - 'cperl-array-face) - t) ; arrays and hashes - ("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)" - 1 - (if (= (- (match-end 2) (match-beginning 2)) 1) - (if (eq (char-after (match-beginning 3)) ?{) - 'cperl-hash-face - 'cperl-array-face) ; arrays and hashes - font-lock-variable-name-face) ; Just to put something - t) - ("\\(@\\|\\$#\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)" - (1 cperl-array-face) - (2 font-lock-variable-name-face)) - ("\\(%\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)" - (1 cperl-hash-face) - (2 font-lock-variable-name-face)) - ;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2") - ;;; Too much noise from \s* @s[ and friends - ;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^ \t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)" - ;;(3 font-lock-function-name-face t t) - ;;(4 - ;; (if (cperl-slash-is-regexp) - ;; font-lock-function-name-face 'default) nil t)) - ))) + '( + ("\\(\\([@%]\\|\\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1 + (if (eq (char-after (match-beginning 2)) ?%) + 'cperl-hash-face + 'cperl-array-face) + t) ; arrays and hashes + ("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)" + 1 + (if (= (- (match-end 2) (match-beginning 2)) 1) + (if (eq (char-after (match-beginning 3)) ?{) + 'cperl-hash-face + 'cperl-array-face) ; arrays and hashes + font-lock-variable-name-face) ; Just to put something + t) + ("\\(@\\|\\$#\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)" + (1 cperl-array-face) + (2 font-lock-variable-name-face)) + ("\\(%\\)\\(\\$+\\([a-zA-Z_:][a-zA-Z0-9_:]*\\|[^ \t\n]\\)\\)" + (1 cperl-hash-face) + (2 font-lock-variable-name-face)) +;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2") +;;; Too much noise from \s* @s[ and friends + ;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^ \t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)" + ;;(3 font-lock-function-name-face t t) + ;;(4 + ;; (if (cperl-slash-is-regexp) + ;; font-lock-function-name-face 'default) nil t)) + )) (if cperl-highlight-variables-indiscriminately (setq t-font-lock-keywords-1 (append t-font-lock-keywords-1 - (list '("\\([$*]{?\\sw+\\)" 1 + (list '("\\([$*]{?\\(?:\\sw+\\|::\\)+\\)" 1 font-lock-variable-name-face))))) (setq cperl-font-lock-keywords-1 (if cperl-syntaxify-by-font-lock @@ -6036,13 +5959,6 @@ indentation and initial hashes. Behaves usually outside of comment." ;; Do it the dull way, without choose-color (defvar cperl-guessed-background nil "Display characteristics as guessed by cperl.") - ;; (or (fboundp 'x-color-defined-p) - ;; (defalias 'x-color-defined-p - ;; (cond ((fboundp 'color-defined-p) 'color-defined-p) - ;; ;; XEmacs >= 19.12 - ;; ((fboundp 'valid-color-name-p) 'valid-color-name-p) - ;; ;; XEmacs 19.11 - ;; (t 'x-valid-color-name-p)))) (cperl-force-face font-lock-constant-face "Face for constant and label names") (cperl-force-face font-lock-variable-name-face @@ -6108,15 +6024,7 @@ indentation and initial hashes. Behaves usually outside of comment." (let ((background (if (boundp 'font-lock-background-mode) font-lock-background-mode - 'light)) - (face-list (and (fboundp 'face-list) (face-list)))) -;;;; (fset 'cperl-is-face -;;;; (cond ((fboundp 'find-face) -;;;; (symbol-function 'find-face)) -;;;; (face-list -;;;; (function (lambda (face) (member face face-list)))) -;;;; (t -;;;; (function (lambda (face) (boundp face)))))) + 'light))) (defvar cperl-guessed-background (if (and (boundp 'font-lock-display-type) (eq font-lock-display-type 'grayscale)) @@ -6155,40 +6063,40 @@ indentation and initial hashes. Behaves usually outside of comment." (if (x-color-defined-p "orchid1") "orchid1" "orange"))))) -;;; (if (cperl-is-face 'font-lock-other-emphasized-face) nil -;;; (copy-face 'bold-italic 'font-lock-other-emphasized-face) -;;; (cond -;;; ((eq background 'light) -;;; (set-face-background 'font-lock-other-emphasized-face -;;; (if (x-color-defined-p "lightyellow2") -;;; "lightyellow2" -;;; (if (x-color-defined-p "lightyellow") -;;; "lightyellow" -;;; "light yellow")))) -;;; ((eq background 'dark) -;;; (set-face-background 'font-lock-other-emphasized-face -;;; (if (x-color-defined-p "navy") -;;; "navy" -;;; (if (x-color-defined-p "darkgreen") -;;; "darkgreen" -;;; "dark green")))) -;;; (t (set-face-background 'font-lock-other-emphasized-face "gray90")))) -;;; (if (cperl-is-face 'font-lock-emphasized-face) nil -;;; (copy-face 'bold 'font-lock-emphasized-face) -;;; (cond -;;; ((eq background 'light) -;;; (set-face-background 'font-lock-emphasized-face -;;; (if (x-color-defined-p "lightyellow2") -;;; "lightyellow2" -;;; "lightyellow"))) -;;; ((eq background 'dark) -;;; (set-face-background 'font-lock-emphasized-face -;;; (if (x-color-defined-p "navy") -;;; "navy" -;;; (if (x-color-defined-p "darkgreen") -;;; "darkgreen" -;;; "dark green")))) -;;; (t (set-face-background 'font-lock-emphasized-face "gray90")))) + ;; (if (cperl-is-face 'font-lock-other-emphasized-face) nil + ;; (copy-face 'bold-italic 'font-lock-other-emphasized-face) + ;; (cond + ;; ((eq background 'light) + ;; (set-face-background 'font-lock-other-emphasized-face + ;; (if (x-color-defined-p "lightyellow2") + ;; "lightyellow2" + ;; (if (x-color-defined-p "lightyellow") + ;; "lightyellow" + ;; "light yellow")))) + ;; ((eq background 'dark) + ;; (set-face-background 'font-lock-other-emphasized-face + ;; (if (x-color-defined-p "navy") + ;; "navy" + ;; (if (x-color-defined-p "darkgreen") + ;; "darkgreen" + ;; "dark green")))) + ;; (t (set-face-background 'font-lock-other-emphasized-face "gray90")))) + ;; (if (cperl-is-face 'font-lock-emphasized-face) nil + ;; (copy-face 'bold 'font-lock-emphasized-face) + ;; (cond + ;; ((eq background 'light) + ;; (set-face-background 'font-lock-emphasized-face + ;; (if (x-color-defined-p "lightyellow2") + ;; "lightyellow2" + ;; "lightyellow"))) + ;; ((eq background 'dark) + ;; (set-face-background 'font-lock-emphasized-face + ;; (if (x-color-defined-p "navy") + ;; "navy" + ;; (if (x-color-defined-p "darkgreen") + ;; "darkgreen" + ;; "dark green")))) + ;; (t (set-face-background 'font-lock-emphasized-face "gray90")))) (if (cperl-is-face 'font-lock-variable-name-face) nil (copy-face 'italic 'font-lock-variable-name-face)) (if (cperl-is-face 'font-lock-constant-face) nil @@ -6237,43 +6145,43 @@ Style of printout regulated by the variable `cperl-ps-print-face-properties'." (require 'ps-print) ; To get ps-print-face-extension-alist (let ((ps-print-color-p t) (ps-print-face-extension-alist ps-print-face-extension-alist)) - (cperl-ps-extend-face-list cperl-ps-print-face-properties) + (ps-extend-face-list cperl-ps-print-face-properties) (ps-print-buffer-with-faces file))) -;;; (defun cperl-ps-print-init () -;;; "Initialization of `ps-print' components for faces used in CPerl." -;;; ;; Guard against old versions -;;; (defvar ps-underlined-faces nil) -;;; (defvar ps-bold-faces nil) -;;; (defvar ps-italic-faces nil) -;;; (setq ps-bold-faces -;;; (append '(font-lock-emphasized-face -;;; cperl-array-face -;;; font-lock-keyword-face -;;; font-lock-variable-name-face -;;; font-lock-constant-face -;;; font-lock-reference-face -;;; font-lock-other-emphasized-face -;;; cperl-hash-face) -;;; ps-bold-faces)) -;;; (setq ps-italic-faces -;;; (append '(cperl-nonoverridable-face -;;; font-lock-constant-face -;;; font-lock-reference-face -;;; font-lock-other-emphasized-face -;;; cperl-hash-face) -;;; ps-italic-faces)) -;;; (setq ps-underlined-faces -;;; (append '(font-lock-emphasized-face -;;; cperl-array-face -;;; font-lock-other-emphasized-face -;;; cperl-hash-face -;;; cperl-nonoverridable-face font-lock-type-face) -;;; ps-underlined-faces)) -;;; (cons 'font-lock-type-face ps-underlined-faces)) - - -(if (cperl-enable-font-lock) (cperl-windowed-init)) +;; (defun cperl-ps-print-init () +;; "Initialization of `ps-print' components for faces used in CPerl." +;; ;; Guard against old versions +;; (defvar ps-underlined-faces nil) +;; (defvar ps-bold-faces nil) +;; (defvar ps-italic-faces nil) +;; (setq ps-bold-faces +;; (append '(font-lock-emphasized-face +;; cperl-array-face +;; font-lock-keyword-face +;; font-lock-variable-name-face +;; font-lock-constant-face +;; font-lock-reference-face +;; font-lock-other-emphasized-face +;; cperl-hash-face) +;; ps-bold-faces)) +;; (setq ps-italic-faces +;; (append '(cperl-nonoverridable-face +;; font-lock-constant-face +;; font-lock-reference-face +;; font-lock-other-emphasized-face +;; cperl-hash-face) +;; ps-italic-faces)) +;; (setq ps-underlined-faces +;; (append '(font-lock-emphasized-face +;; cperl-array-face +;; font-lock-other-emphasized-face +;; cperl-hash-face +;; cperl-nonoverridable-face font-lock-type-face) +;; ps-underlined-faces)) +;; (cons 'font-lock-type-face ps-underlined-faces)) + + +(cperl-windowed-init) (defconst cperl-styles-entries '(cperl-indent-level cperl-brace-offset cperl-continued-brace-offset @@ -6484,16 +6392,14 @@ data already), may be restored by `cperl-set-style-back'. Choosing \"Current\" style will not change style, so this may be used for side-effect of memorizing only. Examples in `cperl-style-examples'." (interactive - (let ((list (mapcar (function (lambda (elt) (list (car elt)))) - cperl-style-alist))) - (list (completing-read "Enter style: " list nil 'insist)))) + (list (completing-read "Enter style: " cperl-style-alist nil 'insist))) (or cperl-old-style (setq cperl-old-style (mapcar (function (lambda (name) (cons name (eval name)))) cperl-styles-entries))) - (let ((style (cdr (assoc style cperl-style-alist))) setting str sym) + (let ((style (cdr (assoc style cperl-style-alist))) setting) (while style (setq setting (car style) style (cdr style)) (set (car setting) (cdr setting))))) @@ -6508,6 +6414,7 @@ side-effect of memorizing only. Examples in `cperl-style-examples'." cperl-old-style (cdr cperl-old-style)) (set (car setting) (cdr setting))))) +(defvar perl-dbg-flags) (defun cperl-check-syntax () (interactive) (require 'mode-compile) @@ -6540,8 +6447,7 @@ side-effect of memorizing only. Examples in `cperl-style-examples'." (set-buffer "*info-perl-tmp*") (rename-buffer "*info*") (set-buffer bname))) - (make-local-variable 'window-min-height) - (setq window-min-height 2) + (set (make-local-variable 'window-min-height) 2) (current-buffer))))) (defun cperl-word-at-point (&optional p) @@ -6572,8 +6478,7 @@ Customized by setting variables `cperl-shrink-wrap-info-frame', default read)))) - (let ((buffer (current-buffer)) - (cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ; "tr///" + (let ((cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ; "tr///" pos isvar height iniheight frheight buf win fr1 fr2 iniwin not-loner max-height char-height buf-list) (if (string-match "^-[a-zA-Z]$" command) @@ -6671,9 +6576,9 @@ Opens Perl Info buffer if needed." (setq imenu-create-index-function 'imenu-default-create-index-function imenu-prev-index-position-function - 'cperl-imenu-info-imenu-search + #'cperl-imenu-info-imenu-search imenu-extract-index-name-function - 'cperl-imenu-info-imenu-name) + #'cperl-imenu-info-imenu-name) (imenu-choose-buffer-index))))) (and index-item (progn @@ -6699,7 +6604,7 @@ If STEP is nil, `cperl-lineup-step' will be used \(or `cperl-indent-level', if `cperl-lineup-step' is nil). Will not move the position at the start to the left." (interactive "r") - (let (search col tcol seen b) + (let (search col tcol seen) (save-excursion (goto-char end) (end-of-line) @@ -6750,8 +6655,8 @@ in subdirectories too." (interactive) (let ((cmd "etags") (args '("-l" "none" "-r" - ;; 1=fullname 2=package? 3=name 4=proto? 5=attrs? (VERY APPROX!) - "/\\<sub[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\(([^()]*)[ \t]*\\)?\\([ \t]*:[^#{;]*\\)?\\([{#]\\|$\\)/\\3/" + ;; 1=fullname 2=package? 3=name 4=proto? 5=attrs? (VERY APPROX!) + "/\\<" cperl-sub-regexp "[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\(([^()]*)[ \t]*\\)?\\([ \t]*:[^#{;]*\\)?\\([{#]\\|$\\)/\\3/" "-r" "/\\<package[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)\\)[ \\t]*\\([#;]\\|$\\)/\\1/" "-r" @@ -6805,17 +6710,16 @@ in subdirectories too." (if (cperl-val 'cperl-electric-parens) "" "not "))) (defun cperl-toggle-autohelp () + ;; FIXME: Turn me into a minor mode. Fix menu entries for "Auto-help on" as + ;; well. "Toggle the state of Auto-Help on Perl constructs (put in the message area). Delay of auto-help controlled by `cperl-lazy-help-time'." (interactive) - (if (fboundp 'run-with-idle-timer) - (progn - (if cperl-lazy-installed - (cperl-lazy-unstall) - (cperl-lazy-install)) - (message "Perl help messages will %sbe automatically shown now." - (if cperl-lazy-installed "" "not "))) - (message "Cannot automatically show Perl help messages - run-with-idle-timer missing."))) + (if cperl-lazy-installed + (cperl-lazy-unstall) + (cperl-lazy-install)) + (message "Perl help messages will %sbe automatically shown now." + (if cperl-lazy-installed "" "not "))) (defun cperl-toggle-construct-fix () "Toggle whether `indent-region'/`indent-sexp' fix whitespace too." @@ -6844,7 +6748,8 @@ by CPerl." (interactive "P") (or arg (setq arg (if (eq cperl-syntaxify-by-font-lock - (if backtrace 'backtrace 'message)) 0 1))) + (if backtrace 'backtrace 'message)) + 0 1))) (setq arg (if (> arg 0) (if backtrace 'backtrace 'message) t)) (setq cperl-syntaxify-by-font-lock arg) (message "Debugging messages of syntax unwind %sabled." @@ -6861,9 +6766,8 @@ by CPerl." (auto-fill-mode 0) (if cperl-use-syntax-table-text-property-for-tags (progn - (make-local-variable 'parse-sexp-lookup-properties) ;; Do not introduce variable if not needed, we check it! - (set 'parse-sexp-lookup-properties t)))) + (set (make-local-variable 'parse-sexp-lookup-properties) t)))) ;; Copied from imenu-example--name-and-position. (defvar imenu-use-markers) @@ -6881,7 +6785,7 @@ Does not move point." (defun cperl-xsub-scan () (require 'imenu) (let ((index-alist '()) - (prev-pos 0) index index1 name package prefix) + index index1 name package prefix) (goto-char (point-min)) ;; Search for the function (progn ;;save-match-data @@ -6921,12 +6825,12 @@ Does not move point." (defun cperl-find-tags (ifile xs topdir) (let ((b (get-buffer cperl-tmp-buffer)) ind lst elt pos ret rel - (cperl-pod-here-fontify nil) f file) + (cperl-pod-here-fontify nil) file) (save-excursion (if b (set-buffer b) (cperl-setup-tmp-buf)) (erase-buffer) - (condition-case err + (condition-case nil (setq file (car (insert-file-contents ifile))) (error (if cperl-unreadable-ok nil (if (y-or-n-p @@ -6940,7 +6844,7 @@ Does not move point." (not xs)) (condition-case err ; after __END__ may have garbage (cperl-find-pods-heres nil nil noninteractive) - (error (message "While scanning for syntax: %s" err)))) + (error (message "While scanning for syntax: %S" err)))) (if xs (setq lst (cperl-xsub-scan)) (setq ind (cperl-imenu--create-perl-index)) @@ -6980,7 +6884,7 @@ Does not move point." (number-to-string (1- (elt elt 1))) ; Char pos 0-based "\n") (if (and (string-match "^[_a-zA-Z]+::" (car elt)) - (string-match "^sub[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]" + (string-match (concat "^" cperl-sub-regexp "[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]") (elt elt 3))) ;; Need to insert the name without package as well (setq lst (cons (cons (substring (elt elt 3) @@ -7038,7 +6942,7 @@ Use as (setq topdir default-directory)) (let ((tags-file-name "TAGS") (case-fold-search (and (featurep 'xemacs) (eq system-type 'emx))) - xs rel tm) + xs rel) (save-excursion (cond (inbuffer nil) ; Already there ((file-exists-p tags-file-name) @@ -7053,7 +6957,7 @@ Use as (erase-buffer) (setq erase 'ignore))) (let ((files - (condition-case err + (condition-case nil (directory-files file t (if recurse nil cperl-scan-files-regexp) t) @@ -7061,8 +6965,9 @@ Use as (if cperl-unreadable-ok nil (if (y-or-n-p (format "Directory %s unreadable. Continue? " file)) - (setq cperl-unreadable-ok t - tm nil) ; Return empty list + (progn + (setq cperl-unreadable-ok t) + nil) ; Return empty list (error "Aborting: unreadable directory %s" file))))))) (mapc (function (lambda (file) @@ -7110,7 +7015,7 @@ Use as "^\\(" "\\(package\\)\\>" "\\|" - "sub\\>[^\n]+::" + cperl-sub-regexp "\\>[^\n]+::" "\\|" "[a-zA-Z_][a-zA-Z_0-9:]*(\C-?[^\n]+::" ; XSUB? "\\|" @@ -7127,10 +7032,9 @@ Use as (defun cperl-tags-hier-fill () ;; Suppose we are in a tag table cooked by cperl. (goto-char 1) - (let (type pack name pos line chunk ord cons1 file str info fileind) + (let (pack name line ord cons1 file info fileind) (while (re-search-forward cperl-tags-hier-regexp-list nil t) - (setq pos (match-beginning 0) - pack (match-beginning 2)) + (setq pack (match-beginning 2)) (beginning-of-line) (if (looking-at (concat "\\([^\n]+\\)" @@ -7182,7 +7086,7 @@ One may build such TAGS files from CPerl mode menu." (or (nthcdr 2 elt) ;; Only in one file (setcdr elt (cdr (nth 1 elt))))))) - pack name cons1 to l1 l2 l3 l4 b) + to l1 l2 l3) ;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later! (setq cperl-hierarchy (list l1 l2 l3)) (if (featurep 'xemacs) ; Not checked @@ -7216,10 +7120,9 @@ One may build such TAGS files from CPerl mode menu." (or (nth 2 cperl-hierarchy) (error "No items found")) (setq update -;;; (imenu-choose-buffer-index "Packages: " (nth 2 cperl-hierarchy)) + ;; (imenu-choose-buffer-index "Packages: " (nth 2 cperl-hierarchy)) (if (if (fboundp 'display-popup-menus-p) - (let ((f 'display-popup-menus-p)) - (funcall f)) + (display-popup-menus-p) window-system) (x-popup-menu t (nth 2 cperl-hierarchy)) (require 'tmm) @@ -7236,22 +7139,20 @@ One may build such TAGS files from CPerl mode menu." (defun cperl-tags-treeify (to level) ;; cadr of `to' is read-write. On start it is a cons (let* ((regexp (concat "^\\(" (mapconcat - 'identity + #'identity (make-list level "[_a-zA-Z0-9]+") "::") "\\)\\(::\\)?")) (packages (cdr (nth 1 to))) (methods (cdr (nth 2 to))) - l1 head tail cons1 cons2 ord writeto packs recurse - root-packages root-functions ms many_ms same_name ps + l1 head cons1 cons2 ord writeto recurse + root-packages root-functions (move-deeper (function (lambda (elt) (cond ((and (string-match regexp (car elt)) (or (eq ord 1) (match-end 2))) (setq head (substring (car elt) 0 (match-end 1)) - tail (if (match-end 2) (substring (car elt) - (match-end 2))) recurse t) (if (setq cons1 (assoc head writeto)) nil ;; Need to init new head @@ -7278,7 +7179,8 @@ One may build such TAGS files from CPerl mode menu." ;;Now clean up leaders with one child only (mapc (function (lambda (elt) (if (not (and (listp (cdr elt)) - (eq (length elt) 2))) nil + (eq (length elt) 2))) + nil (setcar elt (car (nth 1 elt))) (setcdr elt (cdr (nth 1 elt)))))) (cdr to)) @@ -7303,12 +7205,12 @@ One may build such TAGS files from CPerl mode menu." (sort root-packages (default-value 'imenu-sort-function))) root-packages)))) -;;;(x-popup-menu t -;;; '(keymap "Name1" -;;; ("Ret1" "aa") -;;; ("Head1" "ab" -;;; keymap "Name2" -;;; ("Tail1" "x") ("Tail2" "y")))) +;;(x-popup-menu t +;; '(keymap "Name1" +;; ("Ret1" "aa") +;; ("Head1" "ab" +;; keymap "Name2" +;; ("Tail1" "x") ("Tail2" "y")))) (defun cperl-list-fold (list name limit) (let (list1 list2 elt1 (num 0)) @@ -7329,7 +7231,7 @@ One may build such TAGS files from CPerl mode menu." (nreverse list2)) list1))))) -(defun cperl-menu-to-keymap (menu &optional name) +(defun cperl-menu-to-keymap (menu) (let (list) (cons 'keymap (mapcar @@ -7347,7 +7249,7 @@ One may build such TAGS files from CPerl mode menu." (defvar cperl-bad-style-regexp - (mapconcat 'identity + (mapconcat #'identity '("[^-\n\t <>=+!.&|(*/'`\"#^][-=+<>!|&^]" ; char sign "[-<>=+^&|]+[^- \t\n=+<>~]") ; sign+ char "\\|") @@ -7355,7 +7257,7 @@ One may build such TAGS files from CPerl mode menu." (defvar cperl-not-bad-style-regexp (mapconcat - 'identity + #'identity '("[^-\t <>=+]\\(--\\|\\+\\+\\)" ; var-- var++ "[a-zA-Z0-9_][|&][a-zA-Z0-9_$]" ; abc|def abc&def are often used. "&[(a-zA-Z0-9_$]" ; &subroutine &(var->field) @@ -7372,6 +7274,7 @@ One may build such TAGS files from CPerl mode menu." "\\$." ; $| "<<[a-zA-Z_'\"`]" ; <<FOO, <<'FOO' "||" + "//" "&&" "[CBIXSLFZ]<\\(\\sw\\|\\s \\|\\s_\\|[\n]\\)*>" ; C<code like text> "-[a-zA-Z_0-9]+[ \t]*=>" ; -option => value @@ -7393,22 +7296,22 @@ Currently it is tuned to C and Perl syntax." (setq last-nonmenu-event 13) ; To disable popup (goto-char (point-min)) (map-y-or-n-p "Insert space here? " - (lambda (arg) (insert " ")) + (lambda (_) (insert " ")) 'cperl-next-bad-style '("location" "locations" "insert a space into") - '((?\C-r (lambda (arg) - (let ((buffer-quit-function - 'exit-recursive-edit)) - (message "Exit with Esc Esc") - (recursive-edit) - t)) ; Consider acted upon + `((?\C-r ,(lambda (_) + (let ((buffer-quit-function + #'exit-recursive-edit)) + (message "Exit with Esc Esc") + (recursive-edit) + t)) ; Consider acted upon "edit, exit with Esc Esc") - (?e (lambda (arg) - (let ((buffer-quit-function - 'exit-recursive-edit)) - (message "Exit with Esc Esc") - (recursive-edit) - t)) ; Consider acted upon + (?e ,(lambda (_) + (let ((buffer-quit-function + #'exit-recursive-edit)) + (message "Exit with Esc Esc") + (recursive-edit) + t)) ; Consider acted upon "edit, exit with Esc Esc")) t) (if found-bad (goto-char found-bad) @@ -7416,7 +7319,7 @@ Currently it is tuned to C and Perl syntax." (message "No appropriate place found")))) (defun cperl-next-bad-style () - (let (p (not-found t) (point (point)) found) + (let (p (not-found t) found) (while (and not-found (re-search-forward cperl-bad-style-regexp nil 'to-end)) (setq p (point)) @@ -7445,7 +7348,7 @@ Currently it is tuned to C and Perl syntax." (defvar cperl-have-help-regexp ;;(concat "\\(" (mapconcat - 'identity + #'identity '("[$@%*&][0-9a-zA-Z_:]+\\([ \t]*[[{]\\)?" ; Usual variable "[$@]\\^[a-zA-Z]" ; Special variable "[$@][^ \n\t]" ; Special variable @@ -7545,7 +7448,7 @@ than a line. Your contribution to update/shorten it is appreciated." (defun cperl-describe-perl-symbol (val) "Display the documentation of symbol at point, a Perl operator." (let ((enable-recursive-minibuffers t) - args-file regexp) + regexp) (cond ((string-match "^[&*][a-zA-Z_]" val) (setq val (concat (substring val 0 1) "NAME"))) @@ -7712,6 +7615,7 @@ $~ The name of the current report format. ... = ... Assignment. ... == ... Numeric equality. ... =~ ... Search pattern, substitution, or translation +... ~~ .. Smart match ... > ... Numeric greater than. ... >= ... Numeric greater than or equal to. ... >> ... Bitwise shift right. @@ -7749,6 +7653,7 @@ ARGVOUT Output filehandle with -i flag. BEGIN { ... } Immediately executed (during compilation) piece of code. END { ... } Pseudo-subroutine executed after the script finishes. CHECK { ... } Pseudo-subroutine executed after the script is compiled. +UNITCHECK { ... } INIT { ... } Pseudo-subroutine executed before the script starts running. DATA Input filehandle for what follows after __END__ or __DATA__. accept(NEWSOCKET,GENERICSOCKET) @@ -7756,6 +7661,7 @@ alarm(SECONDS) atan2(X,Y) bind(SOCKET,NAME) binmode(FILEHANDLE) +break Break out of a given/when statement caller[(LEVEL)] chdir(EXPR) chmod(LIST) @@ -7771,6 +7677,7 @@ cos(EXPR) crypt(PLAINTEXT,SALT) dbmclose(%HASH) dbmopen(%HASH,DBNAME,MODE) +default { ... } default case for given/when block defined(EXPR) delete($HASH{KEY}) die(LIST) @@ -7787,6 +7694,7 @@ endservent eof[([FILEHANDLE])] ... eq ... String equality. eval(EXPR) or eval { BLOCK } +evalbytes See eval. exec([TRUENAME] ARGV0, ARGVs) or exec(SHELL_COMMAND_LINE) exit(EXPR) exp(EXPR) @@ -7823,6 +7731,7 @@ getservbyport(PORT,PROTO) getservent getsockname(SOCKET) getsockopt(SOCKET,LEVEL,OPTNAME) +given (EXPR) { [ when (EXPR) { ... } ]+ [ default { ... } ]? } gmtime(EXPR) goto LABEL ... gt ... String greater than. @@ -7883,6 +7792,7 @@ rewinddir(DIRHANDLE) rindex(STR,SUBSTR[,OFFSET]) rmdir(FILENAME) s/PATTERN/REPLACEMENT/gieoxsm +say [FILEHANDLE] [(LIST)] scalar(EXPR) seek(FILEHANDLE,POSITION,WHENCE) seekdir(DIRHANDLE,POS) @@ -7917,6 +7827,7 @@ sprintf(FORMAT,LIST) sqrt(EXPR) srand(EXPR) stat(EXPR|FILEHANDLE|VAR) +state VAR or state (VAR1,...) Introduces a static lexical variable study[(SCALAR)] sub [NAME [(format)]] { BODY } sub NAME [(format)]; sub [(format)] {...} substr(EXPR,OFFSET[,LEN]) @@ -7952,6 +7863,7 @@ x= ... Repetition assignment. y/SEARCHLIST/REPLACEMENTLIST/ ... | ... Bitwise or. ... || ... Logical or. +... // ... Defined-or. ~ ... Unary bitwise complement. #! OS interpreter indicator. If contains `perl', used for options, and -x. AUTOLOAD {...} Shorthand for `sub AUTOLOAD {...}'. @@ -7972,6 +7884,7 @@ chr Converts a number to char with the same ordinal. else Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}. elsif Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}. exists $HASH{KEY} True if the key exists. +fc EXPR Returns the casefolded version of EXPR. format [NAME] = Start of output format. Ended by a single dot (.) on a line. formline PICTURE, LIST Backdoor into \"format\" processing. glob EXPR Synonym of <EXPR>. @@ -7983,6 +7896,7 @@ no PACKAGE [SYMBOL1, ...] Partial reverse for `use'. Runs `unimport' method. not ... Low-precedence synonym for ! - negation. ... or ... Low-precedence synonym for ||. pos STRING Set/Get end-position of the last match over this string, see \\G. +prototype FUNC Returns the prototype of a function as a string, or undef. quotemeta [ EXPR ] Quote regexp metacharacters. qw/WORD1 .../ Synonym of split(\\='\\=', \\='WORD1 ...\\=') readline FH Synonym of <FH>. @@ -8005,6 +7919,8 @@ prototype \\&SUB Returns prototype of the function given a reference. =back End list. =cut Switch from POD to Perl. =pod Switch from Perl to POD. +=begin Switch from Perl6 to POD. +=end Switch from POD to Perl6. ") (defun cperl-switch-to-doc-buffer (&optional interactive) @@ -8027,7 +7943,7 @@ prototype \\&SUB Returns prototype of the function given a reference. ;; The REx is guaranteed to have //x ;; LEVEL shows how many levels deep to go ;; position at enter and at leave is not defined - (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline code pos) + (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline pos) (if embed (progn (goto-char b) @@ -8223,8 +8139,8 @@ prototype \\&SUB Returns prototype of the function given a reference. (goto-char (match-end 1)) (re-search-backward "\\s|"))) ; Assume it is scanned already. ;;(forward-char 1) - (let ((b (point)) (e (make-marker)) have-x delim (c (current-column)) - (sub-p (eq (preceding-char) ?s)) s) + (let ((b (point)) (e (make-marker)) have-x delim + (sub-p (eq (preceding-char) ?s))) (forward-sexp 1) (set-marker e (1- (point))) (setq delim (preceding-char)) @@ -8301,7 +8217,7 @@ We suppose that the regexp is scanned already." (cperl-regext-to-level-start) (error ; We are outside outermost group (goto-char (cperl-make-regexp-x)))) - (let ((b (point)) (e (make-marker)) s c) + (let ((b (point)) (e (make-marker))) (forward-sexp 1) (set-marker e (1- (point))) (goto-char (1+ b)) @@ -8513,10 +8429,10 @@ the appropriate statement modifier." (declare-function Man-getpage-in-background "man" (topic)) -;;; By Anthony Foiani <afoiani@uswest.com> -;;; Getting help on modules in C-h f ? -;;; This is a modified version of `man'. -;;; Need to teach it how to lookup functions +;; By Anthony Foiani <afoiani@uswest.com> +;; Getting help on modules in C-h f ? +;; This is a modified version of `man'. +;; Need to teach it how to lookup functions ;;;###autoload (defun cperl-perldoc (word) "Run `perldoc' on WORD." @@ -8544,6 +8460,8 @@ the appropriate statement modifier." (manual-program (if is-func "perldoc -f" "perldoc"))) (cond ((featurep 'xemacs) + (defvar Manual-program) + (defvar Manual-switches) (let ((Manual-program "perldoc") (Manual-switches (if is-func (list "-f")))) (manual-entry word))) @@ -8561,7 +8479,7 @@ the appropriate statement modifier." :type 'file :group 'cperl) -;;; By Nick Roberts <Nick.Roberts@src.bae.co.uk> (with changes) +;; By Nick Roberts <Nick.Roberts@src.bae.co.uk> (with changes) (defun cperl-pod-to-manpage () "Create a virtual manpage in Emacs from the Perl Online Documentation." (interactive) @@ -8578,13 +8496,14 @@ the appropriate statement modifier." (format (cperl-pod2man-build-command) pod2man-args)) 'Man-bgproc-sentinel))))) -;;; Updated version by him too +;; Updated version by him too (defun cperl-build-manpage () "Create a virtual manpage in Emacs from the POD in the file." (interactive) (require 'man) (cond ((featurep 'xemacs) + (defvar Manual-program) (let ((Manual-program "perldoc")) (manual-entry buffer-file-name))) (t @@ -8641,7 +8560,7 @@ a result of qr//, this is not a performance hit), t for the rest." (and (eq (get-text-property beg 'syntax-type) 'string) (setq beg (next-single-property-change beg 'syntax-type nil limit))) (cperl-map-pods-heres - (function (lambda (s e p) + (function (lambda (s _e _p) (if (memq (get-text-property s 'REx-interpolated) skip) t (setq pp s) @@ -8650,27 +8569,27 @@ a result of qr//, this is not a performance hit), t for the rest." (if pp (goto-char pp) (message "No more interpolated REx")))) -;;; Initial version contributed by Trey Belew -(defun cperl-here-doc-spell (&optional beg end) +;; Initial version contributed by Trey Belew +(defun cperl-here-doc-spell () "Spell-check HERE-documents in the Perl buffer. If a region is highlighted, restricts to the region." - (interactive "") - (cperl-pod-spell t beg end)) + (interactive) + (cperl-pod-spell t)) -(defun cperl-pod-spell (&optional do-heres beg end) +(defun cperl-pod-spell (&optional do-heres) "Spell-check POD documentation. If invoked with prefix argument, will do HERE-DOCs instead. If a region is highlighted, restricts to the region." (interactive "P") (save-excursion (let (beg end) - (if (cperl-mark-active) + (if (region-active-p) (setq beg (min (mark) (point)) end (max (mark) (point))) (setq beg (point-min) end (point-max))) (cperl-map-pods-heres (function - (lambda (s e p) + (lambda (s e _p) (if do-heres (setq e (save-excursion (goto-char e) @@ -8699,7 +8618,7 @@ function returns nil." (setq cont (funcall func pos posend prop))) (setq pos posend))))) -;;; Based on code by Masatake YAMATO: +;; Based on code by Masatake YAMATO: (defun cperl-get-here-doc-region (&optional pos pod) "Return HERE document region around the point. Return nil if the point is not in a HERE document region. If POD is non-nil, @@ -8735,7 +8654,7 @@ POS defaults to the point." (push-mark (cdr p) nil t)) ; Message, activate in transient-mode (message "I do not think POS is in POD or a HERE-doc...")))) -(defun cperl-facemenu-add-face-function (face end) +(defun cperl-facemenu-add-face-function (face _end) "A callback to process user-initiated font-change requests. Translates `bold', `italic', and `bold-italic' requests to insertion of corresponding POD directives, and `underline' to C<> POD directive. @@ -8748,7 +8667,7 @@ Such requests are usually bound to M-o LETTER." (italic . "I<") (bold-italic . "B<I<") (underline . "C<"))) - (error "Face %s not configured for cperl-mode" + (error "Face %S not configured for cperl-mode" face)))) (defun cperl-time-fontification (&optional l step lim) @@ -8811,61 +8730,52 @@ may be used to debug problems with delayed incremental fontification." (setq pos p)))) -(defun cperl-lazy-install ()) ; Avoid a warning -(defun cperl-lazy-unstall ()) ; Avoid a warning - -(if (fboundp 'run-with-idle-timer) - (progn - (defvar cperl-help-shown nil - "Non-nil means that the help was already shown now.") +(defvar cperl-help-shown nil + "Non-nil means that the help was already shown now.") - (defvar cperl-lazy-installed nil - "Non-nil means that the lazy-help handlers are installed now.") +(defvar cperl-lazy-installed nil + "Non-nil means that the lazy-help handlers are installed now.") - (defun cperl-lazy-install () - "Switches on Auto-Help on Perl constructs (put in the message area). +;; FIXME: Use eldoc? +(defun cperl-lazy-install () + "Switch on Auto-Help on Perl constructs (put in the message area). Delay of auto-help controlled by `cperl-lazy-help-time'." - (interactive) - (make-local-variable 'cperl-help-shown) - (if (and (cperl-val 'cperl-lazy-help-time) - (not cperl-lazy-installed)) - (progn - (add-hook 'post-command-hook 'cperl-lazy-hook) - (run-with-idle-timer - (cperl-val 'cperl-lazy-help-time 1000000 5) - t - 'cperl-get-help-defer) - (setq cperl-lazy-installed t)))) - - (defun cperl-lazy-unstall () - "Switches off Auto-Help on Perl constructs (put in the message area). + (interactive) + (make-local-variable 'cperl-help-shown) + (if (and (cperl-val 'cperl-lazy-help-time) + (not cperl-lazy-installed)) + (progn + (add-hook 'post-command-hook #'cperl-lazy-hook) + (run-with-idle-timer + (cperl-val 'cperl-lazy-help-time 1000000 5) + t + #'cperl-get-help-defer) + (setq cperl-lazy-installed t)))) + +(defun cperl-lazy-unstall () + "Switch off Auto-Help on Perl constructs (put in the message area). Delay of auto-help controlled by `cperl-lazy-help-time'." - (interactive) - (remove-hook 'post-command-hook 'cperl-lazy-hook) - (cancel-function-timers 'cperl-get-help-defer) - (setq cperl-lazy-installed nil)) + (interactive) + (remove-hook 'post-command-hook #'cperl-lazy-hook) + (cancel-function-timers #'cperl-get-help-defer) + (setq cperl-lazy-installed nil)) - (defun cperl-lazy-hook () - (setq cperl-help-shown nil)) +(defun cperl-lazy-hook () + (setq cperl-help-shown nil)) - (defun cperl-get-help-defer () - (if (not (memq major-mode '(perl-mode cperl-mode))) nil - (let ((cperl-message-on-help-error nil) (cperl-help-from-timer t)) - (cperl-get-help) - (setq cperl-help-shown t)))) - (cperl-lazy-install))) +(defun cperl-get-help-defer () + (if (not (memq major-mode '(perl-mode cperl-mode))) nil + (let ((cperl-message-on-help-error nil) (cperl-help-from-timer t)) + (cperl-get-help) + (setq cperl-help-shown t)))) +(cperl-lazy-install) ;;; Plug for wrong font-lock: (defun cperl-font-lock-unfontify-region-function (beg end) - (let* ((modified (buffer-modified-p)) (buffer-undo-list t) - (inhibit-read-only t) (inhibit-point-motion-hooks t) - (inhibit-modification-hooks t) - deactivate-mark buffer-file-name buffer-file-truename) - (remove-text-properties beg end '(face nil)) - (if (and (not modified) (buffer-modified-p)) - (set-buffer-modified-p nil)))) + (with-silent-modifications + (remove-text-properties beg end '(face nil)))) (defun cperl-font-lock-fontify-region-function (beg end loudly) "Extends the region to safe positions, then calls the default function. @@ -8897,6 +8807,7 @@ do extra unwind via `cperl-unwind-to-safe'." (font-lock-default-fontify-region beg end loudly)) (defvar cperl-d-l nil) +(defvar edebug-backtrace-buffer) ;FIXME: Why? (defun cperl-fontify-syntaxically (end) ;; Some vars for debugging only ;; (message "Syntaxifying...") @@ -8957,7 +8868,7 @@ do extra unwind via `cperl-unwind-to-safe'." nil) ; Do not iterate ;; Called when any modification is made to buffer text. -(defun cperl-after-change-function (beg end old-len) +(defun cperl-after-change-function (beg _end _old-len) ;; We should have been informed about changes by `font-lock'. Since it ;; does not inform as which calls are deferred, do it ourselves (if cperl-syntax-done-to diff --git a/lisp/progmodes/cpp.el b/lisp/progmodes/cpp.el index 6cd02da8f52..432be1aaad8 100644 --- a/lisp/progmodes/cpp.el +++ b/lisp/progmodes/cpp.el @@ -568,6 +568,14 @@ You can also use the keyboard accelerators indicated like this: [K]ey." (set-window-start nil start) (goto-char pos))) +(defun cpp-locate-user-emacs-file (file) + (locate-user-emacs-file + ;; Remove initial '.' from file. + (if (eq (aref file 0) ?.) + (substring file 1) + file) + file)) + (defun cpp-edit-load () "Load cpp configuration." (interactive) @@ -576,8 +584,8 @@ You can also use the keyboard accelerators indicated like this: [K]ey." nil) ((file-readable-p cpp-config-file) (load-file cpp-config-file)) - ((file-readable-p (concat "~/" cpp-config-file)) - (load-file cpp-config-file))) + ((file-readable-p (cpp-locate-user-emacs-file cpp-config-file)) + (load-file (cpp-locate-user-emacs-file cpp-config-file)))) (if (derived-mode-p 'cpp-edit-mode) (cpp-edit-reset))) @@ -586,7 +594,10 @@ You can also use the keyboard accelerators indicated like this: [K]ey." (interactive) (require 'pp) (with-current-buffer cpp-edit-buffer - (let ((buffer (find-file-noselect cpp-config-file))) + (let* ((config-file (if (file-writable-p cpp-config-file) + cpp-config-file + (cpp-locate-user-emacs-file cpp-config-file))) + (buffer (find-file-noselect config-file))) (set-buffer buffer) (erase-buffer) (pp (list 'setq 'cpp-known-face @@ -601,7 +612,7 @@ You can also use the keyboard accelerators indicated like this: [K]ey." (list 'quote cpp-unknown-writable)) buffer) (pp (list 'setq 'cpp-edit-list (list 'quote cpp-edit-list)) buffer) - (write-file cpp-config-file)))) + (write-file config-file)))) (defun cpp-edit-home () "Switch back to original buffer." diff --git a/lisp/progmodes/ebnf-abn.el b/lisp/progmodes/ebnf-abn.el index 1ed07ba17bb..66f1d398df4 100644 --- a/lisp/progmodes/ebnf-abn.el +++ b/lisp/progmodes/ebnf-abn.el @@ -2,8 +2,8 @@ ;; Copyright (C) 2001-2018 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> -;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> +;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, ebnf, PostScript ;; Old-Version: 1.2 ;; Package: ebnf2ps diff --git a/lisp/progmodes/ebnf-bnf.el b/lisp/progmodes/ebnf-bnf.el index 7fe61cd626e..7defe9877b2 100644 --- a/lisp/progmodes/ebnf-bnf.el +++ b/lisp/progmodes/ebnf-bnf.el @@ -2,8 +2,8 @@ ;; Copyright (C) 1999-2018 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> -;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> +;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, ebnf, PostScript ;; Old-Version: 1.10 ;; Package: ebnf2ps diff --git a/lisp/progmodes/ebnf-dtd.el b/lisp/progmodes/ebnf-dtd.el index c0dbc9e3308..2dec3f9159b 100644 --- a/lisp/progmodes/ebnf-dtd.el +++ b/lisp/progmodes/ebnf-dtd.el @@ -2,8 +2,8 @@ ;; Copyright (C) 2001-2018 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> -;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> +;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, ebnf, PostScript ;; Old-Version: 1.1 ;; Package: ebnf2ps diff --git a/lisp/progmodes/ebnf-ebx.el b/lisp/progmodes/ebnf-ebx.el index bbaba13e688..0dc82fc3bff 100644 --- a/lisp/progmodes/ebnf-ebx.el +++ b/lisp/progmodes/ebnf-ebx.el @@ -2,8 +2,8 @@ ;; Copyright (C) 2001-2018 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> -;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> +;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, ebnf, PostScript ;; Old-Version: 1.2 ;; Package: ebnf2ps diff --git a/lisp/progmodes/ebnf-iso.el b/lisp/progmodes/ebnf-iso.el index c6ebc8d3969..06aaf8a3f55 100644 --- a/lisp/progmodes/ebnf-iso.el +++ b/lisp/progmodes/ebnf-iso.el @@ -2,8 +2,8 @@ ;; Copyright (C) 1999-2018 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> -;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> +;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, ebnf, PostScript ;; Old-Version: 1.9 ;; Package: ebnf2ps diff --git a/lisp/progmodes/ebnf-otz.el b/lisp/progmodes/ebnf-otz.el index 3affbcc41d7..5857aa306ba 100644 --- a/lisp/progmodes/ebnf-otz.el +++ b/lisp/progmodes/ebnf-otz.el @@ -2,8 +2,8 @@ ;; Copyright (C) 1999-2018 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> -;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> +;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, ebnf, PostScript ;; Old-Version: 1.0 ;; Package: ebnf2ps diff --git a/lisp/progmodes/ebnf-yac.el b/lisp/progmodes/ebnf-yac.el index 894c9dd9d79..eac0bfc878a 100644 --- a/lisp/progmodes/ebnf-yac.el +++ b/lisp/progmodes/ebnf-yac.el @@ -2,8 +2,8 @@ ;; Copyright (C) 1999-2018 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> -;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> +;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, ebnf, PostScript ;; Old-Version: 1.4 ;; Package: ebnf2ps diff --git a/lisp/progmodes/ebnf2ps.el b/lisp/progmodes/ebnf2ps.el index 40d6af9e654..74ec569214e 100644 --- a/lisp/progmodes/ebnf2ps.el +++ b/lisp/progmodes/ebnf2ps.el @@ -1,9 +1,9 @@ -;;; ebnf2ps.el --- translate an EBNF to a syntactic chart on PostScript +;;; ebnf2ps.el --- translate an EBNF to a syntactic chart on PostScript -*- lexical-binding:t -*- ;; Copyright (C) 1999-2018 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> -;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> +;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, ebnf, PostScript ;; Version: 4.4 ;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre @@ -30,8 +30,7 @@ Vinicius's last change version. When reporting bugs, please also report the version of Emacs, if any, that ebnf2ps was running with. Please send all bug fixes and enhancements to - Vinicius Jose Latorre <viniciusjl@ig.com.br>. -") + Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>.") ;;; Commentary: @@ -1154,6 +1153,7 @@ Please send all bug fixes and enhancements to (require 'ps-print) +(eval-when-compile (require 'cl-lib)) (and (string< ps-print-version "5.2.3") (error "`ebnf2ps' requires `ps-print' package version 5.2.3 or later")) @@ -2047,8 +2047,7 @@ It must be a float between 0.0 (top) and 1.0 (bottom)." (defcustom ebnf-default-width 0.6 - "Specify additional border width over default terminal, non-terminal or -special." + "Additional border width over default terminal, non-terminal or special." :type 'number :version "20" :group 'ebnf2ps) @@ -2252,7 +2251,7 @@ See also `ebnf-print-buffer'." (defun ebnf-print-buffer (&optional filename) "Generate and print a PostScript syntactic chart image of the buffer. -When called with a numeric prefix argument (C-u), prompts the user for +When called with a numeric prefix argument (\\[universal-argument]), prompts the user for the name of a file to save the PostScript image in, instead of sending it to the printer. @@ -2383,6 +2382,7 @@ WARNING: This function does *NOT* ask any confirmation to override existing (ebnf-log-header "(ebnf-eps-buffer)") (ebnf-eps-region (point-min) (point-max))) +(defvar ebnf-eps-executing) ;;;###autoload (defun ebnf-eps-region (from to) @@ -2411,7 +2411,7 @@ WARNING: This function does *NOT* ask any confirmation to override existing ;;;###autoload -(defalias 'ebnf-despool 'ps-despool) +(defalias 'ebnf-despool #'ps-despool) ;;;###autoload @@ -2611,7 +2611,8 @@ See also `ebnf-syntax-buffer'." (defvar ebnf-stack-style nil - "Used in functions `ebnf-reset-style', `ebnf-push-style' and + "Stack of styles. +Used in functions `ebnf-reset-style', `ebnf-push-style' and `ebnf-pop-style'.") @@ -3999,7 +4000,7 @@ See documentation for `ebnf-terminal-shape', `ebnf-non-terminal-shape' and % === end EBNF engine " - "EBNF PostScript prologue") + "EBNF PostScript prologue.") (defconst ebnf-eps-prologue @@ -4276,7 +4277,7 @@ See documentation for `ebnf-terminal-shape', `ebnf-non-terminal-shape' and }bind def " - "EBNF EPS prologue") + "EBNF EPS prologue.") (defconst ebnf-eps-begin @@ -4292,14 +4293,14 @@ end %%EndProlog " - "EBNF EPS begin") + "EBNF EPS begin.") (defconst ebnf-eps-end "#ebnf2ps#end %%EOF " - "EBNF EPS end") + "EBNF EPS end.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -4329,14 +4330,16 @@ end ;; hacked fom `ps-output-string-prim' (ps-print.el) (defun ebnf-eps-string (string) - (let* ((str (string-as-unibyte string)) + (let* ((str string) (len (length str)) (index 0) (new "(") ; insert start-string delimiter start special) ;; Find and quote special characters as necessary for PS - ;; This skips everything except control chars, non-ASCII chars, (, ) and \. - (while (setq start (string-match "[^]-~ -'*-[]" str index)) + ;; This skips everything except control chars, non-ASCII chars, + ;; (, ), \, and DEL. + (while (setq start (string-match "[[:cntrl:][:nonascii:]\177()\\]" + str index)) (setq special (aref str start) new (concat new (substring str index start) @@ -4536,26 +4539,25 @@ end ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; PostScript generation +(defvar ebnf-tree) -(defun ebnf-generate-eps (ebnf-tree) - (let* ((ps-color-p (and ebnf-color-p (ps-color-device))) +(defun ebnf-generate-eps (tree) + (let* ((ebnf-tree tree) + (ps-color-p (and ebnf-color-p (ps-color-device))) (ps-print-color-scale (if ps-color-p (float (car (ps-color-values "white"))) 1.0)) (ebnf-total (length ebnf-tree)) (ebnf-nprod 0) - (old-ps-output (symbol-function 'ps-output)) - (old-ps-output-string (symbol-function 'ps-output-string)) (eps-buffer (get-buffer-create ebnf-eps-buffer-name)) - ebnf-debug-ps error-msg horizontal + ebnf-debug-ps horizontal prod prod-name prod-width prod-height prod-list file-list) - ;; redefines `ps-output' and `ps-output-string' - (defalias 'ps-output 'ebnf-eps-output) - (defalias 'ps-output-string 'ps-output-string-prim) ;; generate EPS file - (save-excursion - (condition-case data - (progn + (unwind-protect + ;; redefines `ps-output' and `ps-output-string' + (cl-letf (((symbol-function 'ps-output) #'ebnf-eps-output) + ((symbol-function 'ps-output-string) #'ps-output-string-prim)) + (save-excursion (while ebnf-tree (setq prod (car ebnf-tree) prod-name (ebnf-node-name prod) @@ -4573,8 +4575,9 @@ end (if (setq prod-list (cdr (assoc prod-name ebnf-eps-production-list))) ;; insert EPS buffer in all buffer associated with production - (ebnf-eps-production-list prod-list 'file-list horizontal - prod-width prod-height eps-buffer) + (ebnf-eps-production-list + prod-list (gv-ref file-list) horizontal + prod-width prod-height eps-buffer) ;; write EPS file for production (ebnf-eps-finish-and-write eps-buffer (ebnf-eps-filename prod-name))) @@ -4584,17 +4587,10 @@ end (setq ebnf-tree (cdr ebnf-tree))) ;; write and kill temporary buffers (ebnf-eps-write-kill-temp file-list t) - (setq file-list nil)) - ;; handler - ((quit error) - (setq error-msg (error-message-string data))))) - ;; restore `ps-output' and `ps-output-string' - (defalias 'ps-output old-ps-output) - (defalias 'ps-output-string old-ps-output-string) - ;; kill temporary buffers - (kill-buffer eps-buffer) - (ebnf-eps-write-kill-temp file-list nil) - (and error-msg (error error-msg)) + (setq file-list nil))) + ;; kill temporary buffers + (kill-buffer eps-buffer) + (ebnf-eps-write-kill-temp file-list nil)) (message " "))) @@ -4610,10 +4606,10 @@ end ;; insert EPS buffer in all buffer associated with production -(defun ebnf-eps-production-list (prod-list file-list-sym horizontal +(defun ebnf-eps-production-list (prod-list file-list-ref horizontal prod-width prod-height eps-buffer) (while prod-list - (add-to-list file-list-sym (car prod-list)) + (cl-pushnew (car prod-list) (gv-deref file-list-ref) :test #'equal) (with-current-buffer (get-buffer-create (concat " *" (car prod-list) "*")) (goto-char (point-max)) (cond @@ -4647,8 +4643,9 @@ end (setq prod-list (cdr prod-list)))) -(defun ebnf-generate (ebnf-tree) - (let* ((ps-color-p (and ebnf-color-p (ps-color-device))) +(defun ebnf-generate (tree) + (let* ((ebnf-tree tree) + (ps-color-p (and ebnf-color-p (ps-color-device))) (ps-print-color-scale (if ps-color-p (float (car (ps-color-values "white"))) 1.0)) @@ -4658,14 +4655,13 @@ end ps-print-begin-page-hook ps-print-begin-column-hook) (ps-generate (current-buffer) (point-min) (point-max) - 'ebnf-generate-postscript))) + #'ebnf-generate-postscript))) -(defvar ebnf-tree nil) (defvar ebnf-direction "R") -(defun ebnf-generate-postscript (from to) +(defun ebnf-generate-postscript (_from _to) (ebnf-begin-file) (if ebnf-horizontal-max-height (ebnf-generate-with-max-height) @@ -5314,9 +5310,9 @@ killed after process termination." "\n%%DocumentNeededResources: font " (or ebnf-fonts-required (setq ebnf-fonts-required - (mapconcat 'identity + (mapconcat #'identity (ps-remove-duplicates - (mapcar 'ebnf-font-name-select + (mapcar #'ebnf-font-name-select (list ebnf-production-font ebnf-terminal-font ebnf-non-terminal-font @@ -5545,7 +5541,7 @@ killed after process termination." (ebnf-log "(ebnf-dimensions tree)") (let ((ebnf-total (length tree)) (ebnf-nprod 0)) - (mapc 'ebnf-production-dimension tree)) + (mapc #'ebnf-production-dimension tree)) tree) @@ -5925,7 +5921,7 @@ killed after process termination." )))) -(defun ebnf-justify (node seq seq-width width last-p) +(defun ebnf-justify (_node seq seq-width width last-p) (let ((term (car (if last-p (last seq) seq)))) (cond ;; adjust empty term diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index 8fe6ef0550b..e6e55a37a7c 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -901,10 +901,11 @@ Semicolons start comments. ;;; Emacs Lisp Byte-Code mode (eval-and-compile - (defconst emacs-list-byte-code-comment-re + (defconst emacs-lisp-byte-code-comment-re (concat "\\(#\\)@\\([0-9]+\\) " ;; Make sure it's a docstring and not a lazy-loaded byte-code. - "\\(?:[^(]\\|([^\"]\\)"))) + "\\(?:[^(]\\|([^\"]\\)") + "Regular expression matching a dynamic doc string comment.")) (defun elisp--byte-code-comment (end &optional _point) "Try to syntactically mark the #@NNN ....^_ docstrings in byte-code files." @@ -913,7 +914,7 @@ Semicolons start comments. (eq (char-after (nth 8 ppss)) ?#)) (let* ((n (save-excursion (goto-char (nth 8 ppss)) - (when (looking-at emacs-list-byte-code-comment-re) + (when (looking-at emacs-lisp-byte-code-comment-re) (string-to-number (match-string 2))))) ;; `maxdiff' tries to make sure the loop below terminates. (maxdiff n)) @@ -939,7 +940,7 @@ Semicolons start comments. (elisp--byte-code-comment end (point)) (funcall (syntax-propertize-rules - (emacs-list-byte-code-comment-re + (emacs-lisp-byte-code-comment-re (1 (prog1 "< b" (elisp--byte-code-comment end (point)))))) start end)) diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index a31668e1baa..4f07fe94855 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -274,12 +274,9 @@ buffer-local and set them to nil." (run-hook-with-args-until-success 'tags-table-format-functions)) ;;;###autoload -(defun tags-table-mode () +(define-derived-mode tags-table-mode special-mode "Tags Table" "Major mode for tags table file buffers." - (interactive) - (setq major-mode 'tags-table-mode ;FIXME: Use define-derived-mode. - mode-name "Tags Table" - buffer-undo-list t) + (setq buffer-undo-list t) (initialize-new-tags-table)) ;;;###autoload @@ -439,25 +436,25 @@ Returns non-nil if it is a valid table." (progn (set-buffer (get-file-buffer file)) (or verify-tags-table-function (tags-table-mode)) - (if (or (verify-visited-file-modtime (current-buffer)) - ;; Decide whether to revert the file. - ;; revert-without-query can say to revert - ;; or the user can say to revert. - (not (or (let ((tail revert-without-query) - (found nil)) - (while tail - (if (string-match (car tail) buffer-file-name) - (setq found t)) - (setq tail (cdr tail))) - found) - tags-revert-without-query - (yes-or-no-p - (format "Tags file %s has changed, read new contents? " - file))))) - (and verify-tags-table-function - (funcall verify-tags-table-function)) + (unless (or (verify-visited-file-modtime (current-buffer)) + ;; Decide whether to revert the file. + ;; revert-without-query can say to revert + ;; or the user can say to revert. + (not (or (let ((tail revert-without-query) + (found nil)) + (while tail + (if (string-match (car tail) buffer-file-name) + (setq found t)) + (setq tail (cdr tail))) + found) + tags-revert-without-query + (yes-or-no-p + (format "Tags file %s has changed, read new contents? " + file))))) (revert-buffer t t) - (tags-table-mode))) + (tags-table-mode)) + (and verify-tags-table-function + (funcall verify-tags-table-function))) (when (file-exists-p file) (let* ((buf (find-file-noselect file)) (newfile (buffer-file-name buf))) @@ -470,7 +467,9 @@ Returns non-nil if it is a valid table." ;; Only change buffer now that we're done using potentially ;; buffer-local variables. (set-buffer buf) - (tags-table-mode))))) + (tags-table-mode) + (and verify-tags-table-function + (funcall verify-tags-table-function)))))) ;; Subroutine of visit-tags-table-buffer. Search the current tags tables ;; for one that has tags for THIS-FILE (or that includes a table that @@ -2060,7 +2059,7 @@ see the doc of that variable if you want to add names to the list." (define-derived-mode select-tags-table-mode special-mode "Select Tags Table" "Major mode for choosing a current tags table among those already loaded." - (setq buffer-read-only t)) + ) (defun select-tags-table-select (button) "Select the tags table named on this line." diff --git a/lisp/progmodes/flymake-proc.el b/lisp/progmodes/flymake-proc.el index c5bb79fee66..f842563be24 100644 --- a/lisp/progmodes/flymake-proc.el +++ b/lisp/progmodes/flymake-proc.el @@ -41,6 +41,8 @@ ;;; Code: +(require 'cl-lib) + (require 'flymake) (define-obsolete-variable-alias 'flymake-compilation-prevents-syntax-check @@ -77,6 +79,13 @@ :group 'flymake :type 'integer) +(defcustom flymake-proc-ignored-file-name-regexps '() + "Files syntax checking is forbidden for. +Overrides `flymake-proc-allowed-file-name-masks'." + :group 'flymake + :type '(repeat (regexp)) + :version "27.1") + (define-obsolete-variable-alias 'flymake-allowed-file-name-masks 'flymake-proc-allowed-file-name-masks "26.1") @@ -106,6 +115,7 @@ ;; ("\\.tex\\'" 1) ) "Files syntax checking is allowed for. +Variable `flymake-proc-ignored-file-name-regexps' overrides this variable. This is an alist with elements of the form: REGEXP INIT [CLEANUP [NAME]] REGEXP is a regular expression that matches a file name. @@ -203,17 +213,22 @@ expression. A match indicates `:warning' type, otherwise :error))) (defun flymake-proc--get-file-name-mode-and-masks (file-name) - "Return the corresponding entry from `flymake-proc-allowed-file-name-masks'." + "Return the corresponding entry from `flymake-proc-allowed-file-name-masks'. +If the FILE-NAME matches a regexp from `flymake-proc-ignored-file-name-regexps', +`flymake-proc-allowed-file-name-masks' is not searched." (unless (stringp file-name) (error "Invalid file-name")) - (let ((fnm flymake-proc-allowed-file-name-masks) - (mode-and-masks nil)) - (while (and (not mode-and-masks) fnm) - (if (string-match (car (car fnm)) file-name) - (setq mode-and-masks (cdr (car fnm)))) - (setq fnm (cdr fnm))) - (flymake-log 3 "file %s, init=%s" file-name (car mode-and-masks)) - mode-and-masks)) + (if (cl-find file-name flymake-proc-ignored-file-name-regexps + :test (lambda (fn rex) (string-match rex fn))) + (flymake-log 3 "file %s ignored") + (let ((fnm flymake-proc-allowed-file-name-masks) + (mode-and-masks nil)) + (while (and (not mode-and-masks) fnm) + (if (string-match (car (car fnm)) file-name) + (setq mode-and-masks (cdr (car fnm)))) + (setq fnm (cdr fnm))) + (flymake-log 3 "file %s, init=%s" file-name (car mode-and-masks)) + mode-and-masks))) (defun flymake-proc--get-init-function (file-name) "Return init function to be used for the file." diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index 58bad8f366e..a47f13fea35 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -415,6 +415,8 @@ Currently accepted REPORT-KEY arguments are: * `:force': value should be a boolean suggesting that Flymake consider the report even if it was somehow unexpected.") +(put 'flymake-diagnostic-functions 'safe-local-variable #'null) + (defvar flymake-diagnostic-types-alist `((:error . ((flymake-category . flymake-error))) diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el index 32d5ced67d0..c664799ab08 100644 --- a/lisp/progmodes/gdb-mi.el +++ b/lisp/progmodes/gdb-mi.el @@ -2717,10 +2717,10 @@ If `default-directory' is remote, full file names are adapted accordingly." (insert "]")))))) (goto-char (point-min)) (insert "{") - (let ((re (concat "\\([[:alnum:]-_]+\\)=\\({\\|\\[\\|\"\"\\|" - gdb--string-regexp "\\)"))) + (let ((re (concat "\\([[:alnum:]-_]+\\)="))) (while (re-search-forward re nil t) - (replace-match "\"\\1\":\\2" nil nil))) + (replace-match "\"\\1\":" nil nil) + (if (eq (char-after) ?\") (forward-sexp) (forward-char)))) (goto-char (point-max)) (insert "}"))) diff --git a/lisp/progmodes/idlwave.el b/lisp/progmodes/idlwave.el index 1d5dc7c7948..a1ea6db64f2 100644 --- a/lisp/progmodes/idlwave.el +++ b/lisp/progmodes/idlwave.el @@ -5240,7 +5240,7 @@ Can run from `after-save-hook'." class (cond ((not (boundp 'idlwave-scanning-lib)) (list 'buffer (buffer-file-name))) -; ((string= (downcase (file-name-base)) +; ((string= (downcase (file-name-base (buffer-file-name)) ; (downcase name)) ; (list 'lib)) ; (t (cons 'lib (file-name-nondirectory (buffer-file-name)))) diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el index 02512ae2de1..f30e591b15a 100644 --- a/lisp/progmodes/js.el +++ b/lisp/progmodes/js.el @@ -3870,7 +3870,6 @@ If one hasn't been set, or if it's stale, prompt for a new one." (setq-local prettify-symbols-alist js--prettify-symbols-alist) (setq-local parse-sexp-ignore-comments t) - (setq-local parse-sexp-lookup-properties t) (setq-local which-func-imenu-joiner-function #'js--which-func-joiner) ;; Comments diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index 4dfc7682c02..1b9e10af29a 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -2392,7 +2392,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"))) - (setq-local parse-sexp-lookup-properties t) (unless sh-use-smie (setq-local sh-kw-alist (sh-feature sh-kw)) (let ((regexp (sh-feature sh-kws-for-done))) diff --git a/lisp/ps-def.el b/lisp/ps-def.el index 9fbb83a74bc..f34473bbb6e 100644 --- a/lisp/ps-def.el +++ b/lisp/ps-def.el @@ -2,10 +2,10 @@ ;; Copyright (C) 2007-2018 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Kenichi Handa <handa@m17n.org> (multi-byte characters) ;; Maintainer: Kenichi Handa <handa@m17n.org> (multi-byte characters) -;; Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, print, PostScript ;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre ;; Package: ps-print diff --git a/lisp/ps-mule.el b/lisp/ps-mule.el index a102d974a46..ae2dd19d2fa 100644 --- a/lisp/ps-mule.el +++ b/lisp/ps-mule.el @@ -2,10 +2,10 @@ ;; Copyright (C) 1998-2018 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Kenichi Handa <handa@m17n.org> (multi-byte characters) ;; Maintainer: Kenichi Handa <handa@m17n.org> (multi-byte characters) -;; Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, print, PostScript, multibyte, mule ;; Package: ps-print diff --git a/lisp/ps-print.el b/lisp/ps-print.el index b1a911724f0..baf290f4be6 100644 --- a/lisp/ps-print.el +++ b/lisp/ps-print.el @@ -4,10 +4,10 @@ ;; Author: Jim Thompson (was <thompson@wg2.waii.com>) ;; Jacques Duthen (was <duthen@cegelec-red.fr>) -;; Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Kenichi Handa <handa@m17n.org> (multi-byte characters) ;; Maintainer: Kenichi Handa <handa@m17n.org> (multi-byte characters) -;; Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, print, PostScript ;; Version: 7.3.5 ;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre @@ -20,7 +20,7 @@ Emacs without changes to the version number. When reporting bugs, please also report the version of Emacs, if any, that ps-print was distributed with. Please send all bug fixes and enhancements to - bug-gnu-emacs@gnu.org and Vinicius Jose Latorre <viniciusjl@ig.com.br>.") + bug-gnu-emacs@gnu.org and Vinicius Jose Latorre <viniciusjl.gnu@gmail.com>.") ;; This file is part of GNU Emacs. @@ -1216,7 +1216,7 @@ Please send all bug fixes and enhancements to ;; New since version 2.8 ;; --------------------- ;; -;; [vinicius] Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; [vinicius] Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; ;; 2007-10-27 ;; `ps-fg-validate-p', `ps-fg-list' @@ -1274,7 +1274,7 @@ Please send all bug fixes and enhancements to ;; ;; `ps-print-region-function' ;; -;; [vinicius] Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; [vinicius] Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; ;; 1999-03-01 ;; PostScript tumble and setpagedevice. @@ -1287,7 +1287,7 @@ Please send all bug fixes and enhancements to ;; ;; Multi-byte buffer handling. ;; -;; [vinicius] Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; [vinicius] Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; ;; 1998-03-06 ;; Skip invisible text. diff --git a/lisp/ps-samp.el b/lisp/ps-samp.el index 9c545ea8537..bd5fff8d8ec 100644 --- a/lisp/ps-samp.el +++ b/lisp/ps-samp.el @@ -4,10 +4,10 @@ ;; Author: Jim Thompson (was <thompson@wg2.waii.com>) ;; Jacques Duthen (was <duthen@cegelec-red.fr>) -;; Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Kenichi Handa <handa@m17n.org> (multi-byte characters) ;; Maintainer: Kenichi Handa <handa@m17n.org> (multi-byte characters) -;; Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: wp, print, PostScript ;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre ;; Package: ps-print diff --git a/lisp/register.el b/lisp/register.el index fa34e608592..77d84c047a9 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -39,9 +39,7 @@ (registerv (:constructor nil) (:constructor registerv--make (&optional data print-func jump-func insert-func)) - (:copier nil) - (:type vector) - :named) + (:copier nil)) (data nil :read-only t) (print-func nil :read-only t) (jump-func nil :read-only t) @@ -59,6 +57,7 @@ this sentence: JUMP-FUNC if provided, controls how `jump-to-register' jumps to the register. INSERT-FUNC if provided, controls how `insert-register' insert the register. They both receive DATA as argument." + (declare (obsolete "Use your own type with methods on register-val-(insert|describe|jump-to)" "27.1")) (registerv--make data print-func jump-func insert-func)) (defvar register-alist nil @@ -182,8 +181,11 @@ Use \\[jump-to-register] to go to that location or restore that configuration. Argument is a character, naming the register. Interactively, reads the register using `register-read-with-preview'." - (interactive (list (register-read-with-preview "Point to register: ") - current-prefix-arg)) + (interactive (list (register-read-with-preview + (if current-prefix-arg + "Frame configuration to register: " + "Point to register: ")) + current-prefix-arg)) ;; Turn the marker into a file-ref if the buffer is killed. (add-hook 'kill-buffer-hook 'register-swap-out nil t) (set-register register @@ -242,36 +244,44 @@ Interactively, reads the register using `register-read-with-preview'." (interactive (list (register-read-with-preview "Jump to register: ") current-prefix-arg)) (let ((val (get-register register))) - (cond - ((registerv-p val) - (cl-assert (registerv-jump-func val) nil - "Don't know how to jump to register %s" - (single-key-description register)) - (funcall (registerv-jump-func val) (registerv-data val))) - ((and (consp val) (frame-configuration-p (car val))) - (set-frame-configuration (car val) (not delete)) - (goto-char (cadr val))) - ((and (consp val) (window-configuration-p (car val))) - (set-window-configuration (car val)) - (goto-char (cadr val))) - ((markerp val) - (or (marker-buffer val) - (user-error "That register's buffer no longer exists")) - (switch-to-buffer (marker-buffer val)) - (unless (or (= (point) (marker-position val)) - (eq last-command 'jump-to-register)) - (push-mark)) - (goto-char val)) - ((and (consp val) (eq (car val) 'file)) - (find-file (cdr val))) - ((and (consp val) (eq (car val) 'file-query)) - (or (find-buffer-visiting (nth 1 val)) - (y-or-n-p (format "Visit file %s again? " (nth 1 val))) - (user-error "Register access aborted")) - (find-file (nth 1 val)) - (goto-char (nth 2 val))) - (t - (user-error "Register doesn't contain a buffer position or configuration"))))) + (register-val-jump-to val delete))) + +(cl-defgeneric register-val-jump-to (_val _arg) + "Execute the \"jump\" operation of VAL. +ARG is the value of the prefix argument or nil." + (user-error "Register doesn't contain a buffer position or configuration")) + +(cl-defmethod register-val-jump-to ((val registerv) _arg) + (cl-assert (registerv-jump-func val) nil + "Don't know how to jump to register value %S" val) + (funcall (registerv-jump-func val) (registerv-data val))) + +(cl-defmethod register-val-jump-to ((val marker) _arg) + (or (marker-buffer val) + (user-error "That register's buffer no longer exists")) + (switch-to-buffer (marker-buffer val)) + (unless (or (= (point) (marker-position val)) + (eq last-command 'jump-to-register)) + (push-mark)) + (goto-char val)) + +(cl-defmethod register-val-jump-to ((val cons) delete) + (cond + ((frame-configuration-p (car val)) + (set-frame-configuration (car val) (not delete)) + (goto-char (cadr val))) + ((window-configuration-p (car val)) + (set-window-configuration (car val)) + (goto-char (cadr val))) + ((eq (car val) 'file) + (find-file (cdr val))) + ((eq (car val) 'file-query) + (or (find-buffer-visiting (nth 1 val)) + (y-or-n-p (format "Visit file %s again? " (nth 1 val))) + (user-error "Register access aborted")) + (find-file (nth 1 val)) + (goto-char (nth 2 val))) + (t (cl-call-next-method val delete)))) (defun register-swap-out () "Turn markers into file-query references when a buffer is killed." @@ -353,79 +363,84 @@ Interactively, reads the register using `register-read-with-preview'." (princ (single-key-description register)) (princ " contains ") (let ((val (get-register register))) + (register-val-describe val verbose))) + +(cl-defgeneric register-val-describe (val verbose) + "Print description of register value VAL to `standard-output'." + (princ "Garbage:\n") + (if verbose (prin1 val))) + +(cl-defmethod register-val-describe ((val registerv) _verbose) + (if (registerv-print-func val) + (funcall (registerv-print-func val) (registerv-data val)) + (princ "[UNPRINTABLE CONTENTS]."))) + +(cl-defmethod register-val-describe ((val number) _verbose) + (princ val)) + +(cl-defmethod register-val-describe ((val marker) _verbose) + (let ((buf (marker-buffer val))) + (if (null buf) + (princ "a marker in no buffer") + (princ "a buffer position:\n buffer ") + (princ (buffer-name buf)) + (princ ", position ") + (princ (marker-position val))))) + +(cl-defmethod register-val-describe ((val cons) verbose) + (cond + ((window-configuration-p (car val)) + (princ "a window configuration.")) + + ((frame-configuration-p (car val)) + (princ "a frame configuration.")) + + ((eq (car val) 'file) + (princ "the file ") + (prin1 (cdr val)) + (princ ".")) + + ((eq (car val) 'file-query) + (princ "a file-query reference:\n file ") + (prin1 (car (cdr val))) + (princ ",\n position ") + (princ (car (cdr (cdr val)))) + (princ ".")) + + (t + (if verbose + (progn + (princ "the rectangle:\n") + (while val + (princ " ") + (princ (car val)) + (terpri) + (setq val (cdr val)))) + (princ "a rectangle starting with ") + (princ (car val)))))) + +(cl-defmethod register-val-describe ((val string) verbose) + (setq val (copy-sequence val)) + (if (eq yank-excluded-properties t) + (set-text-properties 0 (length val) nil val) + (remove-list-of-text-properties 0 (length val) + yank-excluded-properties val)) + (if verbose + (progn + (princ "the text:\n") + (princ val)) (cond - ((registerv-p val) - (if (registerv-print-func val) - (funcall (registerv-print-func val) (registerv-data val)) - (princ "[UNPRINTABLE CONTENTS]."))) - - ((numberp val) - (princ val)) - - ((markerp val) - (let ((buf (marker-buffer val))) - (if (null buf) - (princ "a marker in no buffer") - (princ "a buffer position:\n buffer ") - (princ (buffer-name buf)) - (princ ", position ") - (princ (marker-position val))))) - - ((and (consp val) (window-configuration-p (car val))) - (princ "a window configuration.")) - - ((and (consp val) (frame-configuration-p (car val))) - (princ "a frame configuration.")) - - ((and (consp val) (eq (car val) 'file)) - (princ "the file ") - (prin1 (cdr val)) - (princ ".")) - - ((and (consp val) (eq (car val) 'file-query)) - (princ "a file-query reference:\n file ") - (prin1 (car (cdr val))) - (princ ",\n position ") - (princ (car (cdr (cdr val)))) - (princ ".")) - - ((consp val) - (if verbose - (progn - (princ "the rectangle:\n") - (while val - (princ " ") - (princ (car val)) - (terpri) - (setq val (cdr val)))) - (princ "a rectangle starting with ") - (princ (car val)))) - - ((stringp val) - (setq val (copy-sequence val)) - (if (eq yank-excluded-properties t) - (set-text-properties 0 (length val) nil val) - (remove-list-of-text-properties 0 (length val) - yank-excluded-properties val)) - (if verbose - (progn - (princ "the text:\n") - (princ val)) - (cond - ;; Extract first N characters starting with first non-whitespace. - ((string-match (format "[^ \t\n].\\{,%d\\}" - ;; Deduct 6 for the spaces inserted below. - (min 20 (max 0 (- (window-width) 6)))) - val) - (princ "text starting with\n ") - (princ (match-string 0 val))) - ((string-match "^[ \t\n]+$" val) - (princ "whitespace")) - (t - (princ "the empty string"))))) + ;; Extract first N characters starting with first non-whitespace. + ((string-match (format "[^ \t\n].\\{,%d\\}" + ;; Deduct 6 for the spaces inserted below. + (min 20 (max 0 (- (window-width) 6)))) + val) + (princ "text starting with\n ") + (princ (match-string 0 val))) + ((string-match "^[ \t\n]+$" val) + (princ "whitespace")) (t - (princ "Garbage:\n") - (if verbose (prin1 val)))))) + (princ "the empty string"))))) (defun insert-register (register &optional arg) "Insert contents of register REGISTER. (REGISTER is a character.) @@ -441,24 +456,32 @@ Interactively, reads the register using `register-read-with-preview'." (not current-prefix-arg)))) (push-mark) (let ((val (get-register register))) - (cond - ((registerv-p val) - (cl-assert (registerv-insert-func val) nil - "Don't know how to insert register %s" - (single-key-description register)) - (funcall (registerv-insert-func val) (registerv-data val))) - ((consp val) - (insert-rectangle val)) - ((stringp val) - (insert-for-yank val)) - ((numberp val) - (princ val (current-buffer))) - ((and (markerp val) (marker-position val)) - (princ (marker-position val) (current-buffer))) - (t - (user-error "Register does not contain text")))) + (register-val-insert val)) (if (not arg) (exchange-point-and-mark))) +(cl-defgeneric register-val-insert (_val) + "Insert register value VAL." + (user-error "Register does not contain text")) + +(cl-defmethod register-val-insert ((val registerv)) + (cl-assert (registerv-insert-func val) nil + "Don't know how to insert register value %S" val) + (funcall (registerv-insert-func val) (registerv-data val))) + +(cl-defmethod register-val-insert ((val cons)) + (insert-rectangle val)) + +(cl-defmethod register-val-insert ((val string)) + (insert-for-yank val)) + +(cl-defmethod register-val-insert ((val number)) + (princ val (current-buffer))) + +(cl-defmethod register-val-insert ((val marker)) + (if (marker-position val) + (princ (marker-position val) (current-buffer)) + (cl-call-next-method val))) + (defun copy-to-register (register start end &optional delete-flag region) "Copy region into register REGISTER. With prefix arg, delete as well. diff --git a/lisp/registry.el b/lisp/registry.el index 95097a4f1b7..4928dd9b202 100644 --- a/lisp/registry.el +++ b/lisp/registry.el @@ -358,11 +358,12 @@ return LIMIT such candidates. If SORTFUNC is provided, sort entries first and return candidates from beginning of list." (let* ((precious (oref db precious)) (precious-p (lambda (entry-key) - (cdr (memq (car entry-key) precious)))) + (cdr (memq (car-safe entry-key) precious)))) (data (oref db data)) (candidates (cl-loop for k being the hash-keys of data using (hash-values v) - when (cl-notany precious-p v) + when (and (listp v) + (cl-notany precious-p v)) collect (cons k v)))) ;; We want the full entries for sorting, but should only return a ;; list of entry keys. diff --git a/lisp/replace.el b/lisp/replace.el index 6cee2253746..0db74114b14 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -2212,7 +2212,10 @@ It is called with three arguments, as if it were (if query-replace-lazy-highlight (let ((isearch-string search-string) (isearch-regexp regexp-flag) - (isearch-regexp-function delimited-flag) + (isearch-regexp-function (or delimited-flag + (and replace-char-fold + (not regexp-flag) + #'char-fold-to-regexp))) (isearch-lax-whitespace replace-lax-whitespace) (isearch-regexp-lax-whitespace diff --git a/lisp/rtree.el b/lisp/rtree.el index 71ee0a13b90..ee2fca612f5 100644 --- a/lisp/rtree.el +++ b/lisp/rtree.el @@ -1,4 +1,4 @@ -;;; rtree.el --- functions for manipulating range trees +;;; rtree.el --- functions for manipulating range trees -*- lexical-binding:t -*- ;; Copyright (C) 2010-2018 Free Software Foundation, Inc. @@ -43,9 +43,6 @@ ;;; Code: -(eval-when-compile - (require 'cl)) - (defmacro rtree-make-node () `(list (list nil) nil)) @@ -85,7 +82,7 @@ range) (define-obsolete-function-alias 'rtree-normalise-range - 'rtree-normalize-range "25.1") + #'rtree-normalize-range "25.1") (defun rtree-make (range) "Make an rtree from RANGE." diff --git a/lisp/ruler-mode.el b/lisp/ruler-mode.el index 2e2a589ecf1..02d5a211ba7 100644 --- a/lisp/ruler-mode.el +++ b/lisp/ruler-mode.el @@ -709,20 +709,18 @@ Optional argument PROPS specifies other text properties to apply." ;; Create an "clean" ruler. (ruler (propertize - ;; FIXME: `make-string' returns a unibyte string if it's ASCII-only, - ;; which prevents further `aset' from inserting non-ASCII chars, - ;; hence the need for `string-to-multibyte'. - ;; https://lists.gnu.org/r/emacs-devel/2017-05/msg00841.html - (string-to-multibyte - ;; Make the part of header-line corresponding to the - ;; line-number display be blank, not filled with - ;; ruler-mode-basic-graduation-char. - (if display-line-numbers - (let* ((lndw (round (line-number-display-width 'columns))) - (s (make-string lndw ?\s))) - (concat s (make-string (- w lndw) - ruler-mode-basic-graduation-char))) - (make-string w ruler-mode-basic-graduation-char))) + ;; Make the part of header-line corresponding to the + ;; line-number display be blank, not filled with + ;; ruler-mode-basic-graduation-char. + (if display-line-numbers + (let* ((lndw (round (line-number-display-width 'columns))) + ;; We need a multibyte string here so we could + ;; later use aset to insert multibyte characters + ;; into that string. + (s (make-string lndw ?\s t))) + (concat s (make-string (- w lndw) + ruler-mode-basic-graduation-char t))) + (make-string w ruler-mode-basic-graduation-char t)) 'face 'ruler-mode-default 'local-map ruler-mode-map 'help-echo (cond diff --git a/lisp/simple.el b/lisp/simple.el index 3ac6b86381c..87e0b233779 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -279,23 +279,28 @@ To control which errors are matched, customize the variable `compilation-error-regexp-alist'." (interactive "P") (if (consp arg) (setq reset t arg nil)) - (when (setq next-error-last-buffer (next-error-find-buffer)) - ;; we know here that next-error-function is a valid symbol we can funcall - (with-current-buffer next-error-last-buffer - (funcall next-error-function (prefix-numeric-value arg) reset) - (when next-error-recenter - (recenter next-error-recenter)) - (run-hooks 'next-error-hook)))) + (let ((buffer (next-error-find-buffer))) + (when buffer + ;; We know here that next-error-function is a valid symbol we can funcall + (with-current-buffer buffer + (funcall next-error-function (prefix-numeric-value arg) reset) + ;; Override possible change of next-error-last-buffer in next-error-function + (setq next-error-last-buffer buffer) + (when next-error-recenter + (recenter next-error-recenter)) + (run-hooks 'next-error-hook))))) (defun next-error-internal () "Visit the source code corresponding to the `next-error' message at point." - (setq next-error-last-buffer (current-buffer)) - ;; we know here that next-error-function is a valid symbol we can funcall - (with-current-buffer next-error-last-buffer - (funcall next-error-function 0 nil) - (when next-error-recenter - (recenter next-error-recenter)) - (run-hooks 'next-error-hook))) + (let ((buffer (current-buffer))) + ;; We know here that next-error-function is a valid symbol we can funcall + (with-current-buffer buffer + (funcall next-error-function 0 nil) + ;; Override possible change of next-error-last-buffer in next-error-function + (setq next-error-last-buffer buffer) + (when next-error-recenter + (recenter next-error-recenter)) + (run-hooks 'next-error-hook)))) (defalias 'goto-next-locus 'next-error) (defalias 'next-match 'next-error) @@ -7861,7 +7866,7 @@ buffer buried." (eq mail-user-agent 'message-user-agent) (let (warn-vars) (dolist (var '(mail-mode-hook mail-send-hook mail-setup-hook - mail-yank-hooks mail-archive-file-name + mail-citation-hook mail-archive-file-name mail-default-reply-to mail-mailing-lists mail-self-blind)) (and (boundp var) @@ -8522,13 +8527,16 @@ after it has been set up properly in other respects." ;; Set up other local variables. (mapc (lambda (v) - (condition-case () ;in case var is read-only + (condition-case () (if (symbolp v) (makunbound v) (set (make-local-variable (car v)) (cdr v))) - (error nil))) + (setting-constant nil))) ;E.g. for enable-multibyte-characters. lvars) + (setq mark-ring (mapcar (lambda (mk) (copy-marker (marker-position mk))) + mark-ring)) + ;; Run any hooks (typically set up by the major mode ;; for cloning to work properly). (run-hooks 'clone-buffer-hook)) diff --git a/lisp/startup.el b/lisp/startup.el index 6001dc9a07b..688ea84b7bd 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -781,7 +781,7 @@ to prepare for opening the first frame (e.g. open a connection to an X server)." argval (let ((case-fold-search t) i) - (setq argval (invocation-name)) + (setq argval (copy-sequence invocation-name)) ;; Change any . or * characters in name to ;; hyphens, so as to emulate behavior on X. diff --git a/lisp/subr.el b/lisp/subr.el index 052d9cd8216..46cf5a34ccc 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -78,8 +78,8 @@ If FORM does return, signal an error." (defmacro 1value (form) "Evaluate FORM, expecting a constant return value. -This is the global do-nothing version. There is also `testcover-1value' -that complains if FORM ever does return differing values." +If FORM returns differing values when running under Testcover, +Testcover will raise an error." (declare (debug t)) form) @@ -1438,6 +1438,10 @@ be a list of the form returned by `event-start' and `event-end'." (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." + "27.1") +(make-obsolete 'invocation-name "use the variable of the same name." "27.1") + ;; bug#23850 (make-obsolete 'string-to-unibyte "use `encode-coding-string'." "26.1") (make-obsolete 'string-as-unibyte "use `encode-coding-string'." "26.1") @@ -1479,10 +1483,6 @@ be a list of the form returned by `event-start' and `event-end'." (make-obsolete-variable 'command-debug-status "expect it to be removed in a future version." "25.2") -;; Lisp manual only updated in 22.1. -(define-obsolete-variable-alias 'executing-macro 'executing-kbd-macro - "before 19.34") - (define-obsolete-variable-alias 'x-lost-selection-hooks 'x-lost-selection-functions "22.1") (define-obsolete-variable-alias 'x-sent-selection-hooks @@ -1839,15 +1839,13 @@ if it is empty or a duplicate." (defvar delay-mode-hooks nil "If non-nil, `run-mode-hooks' should delay running the hooks.") -(defvar delayed-mode-hooks nil +(defvar-local delayed-mode-hooks nil "List of delayed mode hooks waiting to be run.") -(make-variable-buffer-local 'delayed-mode-hooks) (put 'delay-mode-hooks 'permanent-local t) -(defvar delayed-after-hook-functions nil +(defvar-local delayed-after-hook-functions nil "List of delayed :after-hook forms waiting to be run. These forms come from `define-derived-mode'.") -(make-variable-buffer-local 'delayed-after-hook-functions) (defvar change-major-mode-after-body-hook nil "Normal hook run in major mode functions, before the mode hooks.") @@ -1876,15 +1874,22 @@ running their FOO-mode-hook." (push hook delayed-mode-hooks)) ;; Normal case, just run the hook as before plus any delayed hooks. (setq hooks (nconc (nreverse delayed-mode-hooks) hooks)) + (and syntax-propertize-function + (not (local-variable-p 'parse-sexp-lookup-properties)) + ;; `syntax-propertize' sets `parse-sexp-lookup-properties' for us, but + ;; in order for the sexp primitives to automatically call + ;; `syntax-propertize' we need `parse-sexp-lookup-properties' to be + ;; set first. + (setq-local parse-sexp-lookup-properties t)) (setq delayed-mode-hooks nil) - (apply 'run-hooks (cons 'change-major-mode-after-body-hook hooks)) + (apply #'run-hooks (cons 'change-major-mode-after-body-hook hooks)) (if (buffer-file-name) (with-demoted-errors "File local-variables error: %s" (hack-local-variables 'no-mode))) (run-hooks 'after-change-major-mode-hook) - (dolist (fun (nreverse delayed-after-hook-functions)) - (funcall fun)) - (setq delayed-after-hook-functions nil))) + (dolist (fun (prog1 (nreverse delayed-after-hook-functions) + (setq delayed-after-hook-functions nil))) + (funcall fun)))) (defmacro delay-mode-hooks (&rest body) "Execute BODY, but delay any `run-mode-hooks'. @@ -4529,10 +4534,10 @@ EVALD, FUNC, ARGS, FLAGS are as in `mapbacktrace'." (princ (if (plist-get flags :debug-on-exit) "* " " ")) (cond ((and evald (not debugger-stack-frame-as-list)) - (prin1 func) - (if args (prin1 args) (princ "()"))) + (cl-prin1 func) + (if args (cl-prin1 args) (princ "()"))) (t - (prin1 (cons func args)))) + (cl-prin1 (cons func args)))) (princ "\n")) (defun backtrace () diff --git a/lisp/svg.el b/lisp/svg.el index c0fa26ade03..1178905546a 100644 --- a/lisp/svg.el +++ b/lisp/svg.el @@ -157,7 +157,27 @@ otherwise. IMAGE-TYPE should be a MIME image type, like (dom-node 'text `(,@(svg--arguments svg args)) - text))) + (svg--encode-text text)))) + +(defun svg--encode-text (text) + ;; Apparently the SVG renderer needs to have all non-ASCII + ;; characters encoded, and only certain special characters. + (with-temp-buffer + (insert text) + (dolist (substitution '(("&" . "&") + ("<" . "<") + (">" . ">"))) + (goto-char (point-min)) + (while (search-forward (car substitution) nil t) + (replace-match (cdr substitution) t t nil))) + (goto-char (point-min)) + (while (not (eobp)) + (let ((char (following-char))) + (if (< char 128) + (forward-char 1) + (delete-char 1) + (insert "&#" (format "%d" char) ";")))) + (buffer-string))) (defun svg--append (svg node) (let ((old (and (dom-attr node 'id) diff --git a/lisp/term/common-win.el b/lisp/term/common-win.el index 5df635a145d..6ef686a996f 100644 --- a/lisp/term/common-win.el +++ b/lisp/term/common-win.el @@ -112,7 +112,7 @@ ;; Handle the -xrm option. (defun x-handle-xrm-switch (switch) (unless (consp x-invocation-args) - (error "%s: missing argument to `%s' option" (invocation-name) switch)) + (error "%s: missing argument to `%s' option" invocation-name switch)) (setq x-command-line-resources (if (null x-command-line-resources) (pop x-invocation-args) @@ -152,7 +152,7 @@ ;; the initial frame, too. (defun x-handle-name-switch (switch) (or (consp x-invocation-args) - (error "%s: missing argument to `%s' option" (invocation-name) switch)) + (error "%s: missing argument to `%s' option" invocation-name switch)) (setq x-resource-name (pop x-invocation-args) initial-frame-alist (cons (cons 'name x-resource-name) initial-frame-alist))) diff --git a/lisp/term/ns-win.el b/lisp/term/ns-win.el index 618041dbe27..aa3113bd340 100644 --- a/lisp/term/ns-win.el +++ b/lisp/term/ns-win.el @@ -42,7 +42,7 @@ (eval-when-compile (require 'cl-lib)) (or (featurep 'ns) (error "%s: Loading ns-win.el but not compiled for GNUstep/macOS" - (invocation-name))) + invocation-name)) ;; Documentation-purposes only: actually loaded in loadup.el. (require 'frame) @@ -144,6 +144,8 @@ The properties returned may include `top', `left', `height', and `width'." (define-key global-map [?\s-z] 'undo) (define-key global-map [?\s-|] 'shell-command-on-region) (define-key global-map [s-kp-bar] 'shell-command-on-region) +(define-key global-map [C-s- ] 'ns-do-show-character-palette) +(define-key key-translation-map [C-s-268632064] [C-s- ]) ;; (as in Terminal.app) (define-key global-map [s-right] 'ns-next-frame) (define-key global-map [s-left] 'ns-prev-frame) @@ -354,7 +356,7 @@ See `ns-insert-working-text'." ;; Used prior to Emacs 25. (define-coding-system-alias 'utf-8-nfd 'utf-8-hfs) - (set-file-name-coding-system 'utf-8-hfs)) + (set-file-name-coding-system 'utf-8-hfs-unix)) ;;;; Inter-app communications support. @@ -575,6 +577,12 @@ the last file dropped is selected." (interactive) (ns-emacs-info-panel)) +(declare-function ns-show-character-palette "nsfns.m" ()) + +(defun ns-do-show-character-palette () + (interactive) + (ns-show-character-palette)) + (defun ns-next-frame () "Switch to next visible frame." (interactive) diff --git a/lisp/term/pc-win.el b/lisp/term/pc-win.el index 7c9c84b0a7d..f49ad7a4830 100644 --- a/lisp/term/pc-win.el +++ b/lisp/term/pc-win.el @@ -38,7 +38,7 @@ (if (not (fboundp 'msdos-remember-default-colors)) (error "%s: Loading pc-win.el but not compiled for MS-DOS" - (invocation-name))) + invocation-name)) (declare-function msdos-remember-default-colors "msdos.c") (declare-function w16-set-clipboard-data "w16select.c") diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index ed76490751e..28eaeff6056 100644 --- a/lisp/term/w32-win.el +++ b/lisp/term/w32-win.el @@ -66,7 +66,7 @@ ;; ../startup.el. ;; (if (not (eq window-system 'w32)) -;; (error "%s: Loading w32-win.el but not compiled for w32" (invocation-name))) +;; (error "%s: Loading w32-win.el but not compiled for w32" invocation-name)) (eval-when-compile (require 'cl-lib)) (require 'frame) @@ -276,7 +276,8 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") '(gnutls "libgnutls-28.dll" "libgnutls-26.dll")) '(libxml2 "libxml2-2.dll" "libxml2.dll") '(zlib "zlib1.dll" "libz-1.dll") - '(lcms2 "liblcms2-2.dll"))) + '(lcms2 "liblcms2-2.dll") + '(json "libjansson-4.dll"))) ;;; multi-tty support (defvar w32-initialized nil @@ -309,7 +310,7 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") (setq x-resource-name ;; Change any . or * characters in x-resource-name to hyphens, ;; so as not to choke when we use it in X resource queries. - (replace-regexp-in-string "[.*]" "-" (invocation-name)))) + (replace-regexp-in-string "[.*]" "-" invocation-name))) (x-open-connection "w32" x-command-line-resources ;; Exit with a fatal error if this fails and we diff --git a/lisp/term/x-win.el b/lisp/term/x-win.el index e3196ab84e3..f169b27bc47 100644 --- a/lisp/term/x-win.el +++ b/lisp/term/x-win.el @@ -69,7 +69,7 @@ (eval-when-compile (require 'cl-lib)) (if (not (fboundp 'x-create-frame)) - (error "%s: Loading x-win.el but not compiled for X" (invocation-name))) + (error "%s: Loading x-win.el but not compiled for X" invocation-name)) (require 'term/common-win) (require 'frame) @@ -93,7 +93,7 @@ ;; Handle the --parent-id option. (defun x-handle-parent-id (switch) (or (consp x-invocation-args) - (error "%s: missing argument to `%s' option" (invocation-name) switch)) + (error "%s: missing argument to `%s' option" invocation-name switch)) (setq initial-frame-alist (cons (cons 'parent-id (string-to-number (car x-invocation-args))) @@ -104,7 +104,7 @@ ;; to give us back our session id we had on the previous run. (defun x-handle-smid (switch) (or (consp x-invocation-args) - (error "%s: missing argument to `%s' option" (invocation-name) switch)) + (error "%s: missing argument to `%s' option" invocation-name switch)) (setq x-session-previous-id (car x-invocation-args) x-invocation-args (cdr x-invocation-args))) @@ -1205,7 +1205,7 @@ This returns an error if any Emacs frames are X frames." ;; Make sure we have a valid resource name. (or (stringp x-resource-name) (let (i) - (setq x-resource-name (invocation-name)) + (setq x-resource-name (copy-sequence invocation-name)) ;; Change any . or * characters in x-resource-name to hyphens, ;; so as not to choke when we use it in X resource queries. diff --git a/lisp/term/xterm.el b/lisp/term/xterm.el index 6f0d128b3d5..2a982917a85 100644 --- a/lisp/term/xterm.el +++ b/lisp/term/xterm.el @@ -68,6 +68,11 @@ string bytes that can be copied is 3/4 of this value." :version "25.1" :type 'integer) +(defcustom xterm-set-window-title nil + "Whether Emacs should set window titles to an Emacs frame in an XTerm." + :version "27.1" + :type 'boolean) + (defconst xterm-paste-ending-sequence "\e[201~" "Characters send by the terminal to end a bracketed paste.") @@ -802,6 +807,8 @@ We run the first FUNCTION whose STRING matches the input events." (when (memq 'setSelection xterm-extra-capabilities) (xterm--init-activate-set-selection))) + (when xterm-set-window-title + (xterm--init-frame-title)) ;; Unconditionally enable bracketed paste mode: terminals that don't ;; support it just ignore the sequence. (xterm--init-bracketed-paste-mode) @@ -828,6 +835,34 @@ We run the first FUNCTION whose STRING matches the input events." "Terminal initialization for `gui-set-selection'." (set-terminal-parameter nil 'xterm--set-selection t)) +(defun xterm--init-frame-title () + "Terminal initialization for XTerm frame titles." + (xterm-set-window-title) + (add-hook 'after-make-frame-functions 'xterm-set-window-title-flag) + (add-hook 'window-configuration-change-hook 'xterm-unset-window-title-flag) + (add-hook 'post-command-hook 'xterm-set-window-title) + (add-hook 'minibuffer-exit-hook 'xterm-set-window-title)) + +(defvar xterm-window-title-flag nil + "Whether a new frame has been created, calling for a title update.") + +(defun xterm-set-window-title-flag (_frame) + "Set `xterm-window-title-flag'. +See `xterm--init-frame-title'" + (setq xterm-window-title-flag t)) + +(defun xterm-unset-window-title-flag () + (when xterm-window-title-flag + (setq xterm-window-title-flag nil) + (xterm-set-window-title))) + +(defun xterm-set-window-title (&optional terminal) + "Set the window title of the Xterm TERMINAL. +The title is constructed from `frame-title-format'." + (send-string-to-terminal + (format "\e]2;%s\a" (format-mode-line frame-title-format)) + terminal)) + (defun xterm--selection-char (type) (pcase type ('PRIMARY "p") diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el index 922c1bfe13e..1d13070f120 100644 --- a/lisp/textmodes/css-mode.el +++ b/lisp/textmodes/css-mode.el @@ -32,12 +32,13 @@ ;;; Code: -(require 'eww) (require 'cl-lib) (require 'color) +(require 'eww) (require 'seq) (require 'sgml-mode) (require 'smie) +(require 'thingatpt) (eval-when-compile (require 'subr-x)) (defgroup css nil @@ -806,6 +807,7 @@ cannot be completed sensibly: `custom-ident', (defvar css-mode-map (let ((map (make-sparse-keymap))) (define-key map [remap info-lookup-symbol] 'css-lookup-symbol) + (define-key map "\C-c\C-f" 'css-cycle-color-format) map) "Keymap used in `css-mode'.") @@ -896,7 +898,7 @@ cannot be completed sensibly: `custom-ident', ;; No face. nil))) ;; Variables. - (,(concat "--" css-ident-re) (0 font-lock-variable-name-face)) + (,(concat (rx symbol-start) "--" css-ident-re) (0 font-lock-variable-name-face)) ;; Properties. Again, we don't limit ourselves to css-property-ids. (,(concat "\\(?:[{;]\\|^\\)[ \t]*\\(" "\\(?:\\(" css-proprietary-nmstart-re "\\)\\|" @@ -936,11 +938,13 @@ cannot be completed sensibly: `custom-ident', "Skip blanks and comments." (while (forward-comment 1))) -(cl-defun css--rgb-color () +(cl-defun css--rgb-color (&optional include-alpha) "Parse a CSS rgb() or rgba() color. Point should be just after the open paren. Returns a hex RGB color, or nil if the color could not be recognized. -This recognizes CSS-color-4 extensions." +This recognizes CSS-color-4 extensions. +When INCLUDE-ALPHA is non-nil, the alpha component is included in +the returned hex string." (let ((result '()) (iter 0)) (while (< iter 4) @@ -952,8 +956,8 @@ This recognizes CSS-color-4 extensions." (number (string-to-number str))) (when is-percent (setq number (* 255 (/ number 100.0)))) - ;; Don't push the alpha. - (when (< iter 3) + (if (and include-alpha (= iter 3)) + (push (round (* number 255)) result) (push (min (max 0 (truncate number)) 255) result)) (goto-char (match-end 0)) (css--color-skip-blanks) @@ -966,7 +970,11 @@ This recognizes CSS-color-4 extensions." (css--color-skip-blanks))) (when (looking-at ")") (forward-char) - (apply #'format "#%02x%02x%02x" (nreverse result))))) + (apply #'format + (if (and include-alpha (= (length result) 4)) + "#%02x%02x%02x%02x" + "#%02x%02x%02x") + (nreverse result))))) (cl-defun css--hsl-color () "Parse a CSS hsl() or hsla() color. @@ -1037,9 +1045,15 @@ This recognizes CSS-color-4 extensions." STR is the incoming CSS hex color. This function simply drops any transparency." ;; Either #RGB or #RRGGBB, drop the "A" or "AA". - (if (> (length str) 5) - (substring str 0 7) - (substring str 0 4))) + (substring str 0 (if (> (length str) 5) 7 4))) + +(defun css--hex-alpha (hex) + "Return the alpha component of CSS color HEX. +HEX can either be in the #RGBA or #RRGGBBAA format. Return nil +if the color doesn't have an alpha component." + (cl-case (length hex) + (5 (string (elt hex 4))) + (9 (substring hex 7 9)))) (defun css--named-color (start-point str) "Check whether STR, seen at point, is CSS named color. @@ -1383,6 +1397,111 @@ tags, classes and IDs." (progn (insert ": ;") (forward-char -1)))))))))) +(defun css--color-to-4-dpc (hex) + "Convert the CSS color HEX to four digits per component. +CSS colors use one or two digits per component for RGB hex +values. Convert the given color to four digits per component. + +Note that this function handles CSS colors specifically, and +should not be mixed with those in color.el." + (let ((six-digits (= (length hex) 7))) + (apply + #'concat + `("#" + ,@(seq-mapcat + (apply-partially #'make-list (if six-digits 2 4)) + (seq-partition (seq-drop hex 1) (if six-digits 2 1))))))) + +(defun css--named-color-to-hex () + "Convert named CSS color at point to hex format. +Return non-nil if a conversion was made. + +Note that this function handles CSS colors specifically, and +should not be mixed with those in color.el." + (save-excursion + (unless (or (looking-at css--colors-regexp) + (eq (char-before) ?#)) + (backward-word)) + (when (member (word-at-point) (mapcar #'car css--color-map)) + (looking-at css--colors-regexp) + (let ((color (css--compute-color (point) (match-string 0)))) + (replace-match color)) + t))) + +(defun css--format-rgba-alpha (alpha) + "Return ALPHA component formatted for use in rgba()." + (let ((a (string-to-number (format "%.2f" alpha)))) + (if (or (= a 0) + (= a 1)) + (format "%d" a) + (string-remove-suffix "0" (number-to-string a))))) + +(defun css--hex-to-rgb () + "Convert CSS hex color at point to RGB format. +Return non-nil if a conversion was made. + +Note that this function handles CSS colors specifically, and +should not be mixed with those in color.el." + (save-excursion + (unless (or (eq (char-after) ?#) + (eq (char-before) ?\()) + (backward-sexp)) + (when-let* ((hex (when (looking-at css--colors-regexp) + (and (eq (elt (match-string 0) 0) ?#) + (match-string 0)))) + (rgb (css--hex-color hex))) + (seq-let (r g b) + (mapcar (lambda (x) (round (* x 255))) + (color-name-to-rgb (css--color-to-4-dpc rgb))) + (replace-match + (if-let* ((alpha (css--hex-alpha hex)) + (a (css--format-rgba-alpha + (/ (string-to-number alpha 16) + (float (expt 16 (length alpha))))))) + (format "rgba(%d, %d, %d, %s)" r g b a) + (format "rgb(%d, %d, %d)" r g b)) + t)) + t))) + +(defun css--rgb-to-named-color-or-hex () + "Convert CSS RGB color at point to a named color or hex format. +Convert to a named color if the color at point has a name, else +convert to hex format. Return non-nil if a conversion was made. + +Note that this function handles CSS colors specifically, and +should not be mixed with those in color.el." + (save-excursion + (when-let* ((open-paren-pos (nth 1 (syntax-ppss)))) + (when (save-excursion + (goto-char open-paren-pos) + (looking-back "rgba?" (- (point) 4))) + (goto-char (nth 1 (syntax-ppss))))) + (when (eq (char-before) ?\)) + (backward-sexp)) + (skip-chars-backward "rgba") + (when (looking-at css--colors-regexp) + (let* ((start (match-end 0)) + (color (save-excursion + (goto-char start) + (css--rgb-color t)))) + (when color + (kill-sexp) + (kill-sexp) + (let ((named-color (seq-find (lambda (x) (equal (cdr x) color)) + css--color-map))) + (insert (if named-color (car named-color) color))) + t))))) + +(defun css-cycle-color-format () + "Cycle the color at point between different CSS color formats. +Supported formats are by name (if possible), hexadecimal, and +rgb()/rgba()." + (interactive) + (or (css--named-color-to-hex) + (css--hex-to-rgb) + (css--rgb-to-named-color-or-hex) + (message "It doesn't look like a color at point"))) + ;;;###autoload (define-derived-mode css-mode prog-mode "CSS" "Major mode to edit Cascading Style Sheets (CSS). diff --git a/lisp/textmodes/fill.el b/lisp/textmodes/fill.el index ce83ad737b1..a46f0b2a4cd 100644 --- a/lisp/textmodes/fill.el +++ b/lisp/textmodes/fill.el @@ -128,10 +128,11 @@ if it would act as a paragraph-starter on the second line." :type 'regexp :group 'fill) -(defcustom adaptive-fill-function nil - "Function to call to choose a fill prefix for a paragraph, or nil. -A nil value means the function has not determined the fill prefix." - :type '(choice (const nil) function) +(defcustom adaptive-fill-function #'ignore + "Function to call to choose a fill prefix for a paragraph. +A nil return value means the function has not determined the fill prefix." + :version "27.1" + :type 'function :group 'fill) (defvar fill-indent-according-to-mode nil ;Screws up CC-mode's filling tricks. diff --git a/lisp/textmodes/mhtml-mode.el b/lisp/textmodes/mhtml-mode.el index b99f788156c..28c248fb0c4 100644 --- a/lisp/textmodes/mhtml-mode.el +++ b/lisp/textmodes/mhtml-mode.el @@ -364,7 +364,6 @@ Code inside a <script> element is indented using the rules from `js-mode'; and code inside a <style> element is indented using the rules from `css-mode'." (setq-local indent-line-function #'mhtml-indent-line) - (setq-local parse-sexp-lookup-properties t) (setq-local syntax-propertize-function #'mhtml-syntax-propertize) (setq-local font-lock-fontify-region-function #'mhtml--submode-fontify-region) diff --git a/lisp/textmodes/page-ext.el b/lisp/textmodes/page-ext.el index 61f02190065..8a41bc37422 100644 --- a/lisp/textmodes/page-ext.el +++ b/lisp/textmodes/page-ext.el @@ -1,4 +1,4 @@ -;;; page-ext.el --- extended page handling commands +;;; page-ext.el --- extended page handling commands -*- lexical-binding:t -*- ;; Copyright (C) 1990-1991, 1993-1994, 2001-2018 Free Software ;; Foundation, Inc. @@ -243,18 +243,15 @@ (defcustom pages-directory-buffer-narrowing-p t "If non-nil, `pages-directory-goto' narrows pages buffer to entry." - :type 'boolean - :group 'pages) + :type 'boolean) (defcustom pages-directory-for-adding-page-narrowing-p t "If non-nil, `add-new-page' narrows page buffer to new entry." - :type 'boolean - :group 'pages) + :type 'boolean) (defcustom pages-directory-for-adding-new-page-before-current-page-p t "If non-nil, `add-new-page' inserts new page before current page." - :type 'boolean - :group 'pages) + :type 'boolean) ;;; Addresses related variables @@ -262,23 +259,19 @@ (defcustom pages-addresses-file-name "~/addresses" "Standard name for file of addresses. Entries separated by page-delimiter. Used by `pages-directory-for-addresses' function." - :type 'file - :group 'pages) + :type 'file) (defcustom pages-directory-for-addresses-goto-narrowing-p t "If non-nil, `pages-directory-goto' narrows addresses buffer to entry." - :type 'boolean - :group 'pages) + :type 'boolean) (defcustom pages-directory-for-addresses-buffer-keep-windows-p t "If nil, `pages-directory-for-addresses' deletes other windows." - :type 'boolean - :group 'pages) + :type 'boolean) (defcustom pages-directory-for-adding-addresses-narrowing-p t "If non-nil, `add-new-page' narrows addresses buffer to new entry." - :type 'boolean - :group 'pages) + :type 'boolean) ;;; Key bindings for page handling functions @@ -415,9 +408,9 @@ Point is left in the body of page." Called from a program, there are three arguments: REVERSE (non-nil means reverse order), BEG and END (region to sort)." -;;; This sort function handles ends of pages differently than -;;; `sort-pages' and works better with lists of addresses and similar -;;; files. + ;; This sort function handles ends of pages differently than + ;; `sort-pages' and works better with lists of addresses and similar + ;; files. (interactive "P\nr") (save-restriction @@ -463,25 +456,27 @@ REVERSE (non-nil means reverse order), BEG and END (region to sort)." \(This regular expression may be used to select only those pages that contain matches to the regexp.)") -(defvar pages-buffer nil +(defvar-local pages-buffer nil "The buffer for which the pages-directory function creates the directory.") (defvar pages-directory-prefix "*Directory for:" "Prefix of name of temporary buffer for pages-directory.") -(defvar pages-pos-list nil +(defvar-local pages-pos-list nil "List containing the positions of the pages in the pages-buffer.") (defvar pages-target-buffer) +(define-obsolete-variable-alias 'pages-directory-map + 'pages-directory-mode-map "26.1") (defvar pages-directory-mode-map (let ((map (make-sparse-keymap))) (define-key map "\C-c\C-c" 'pages-directory-goto) + (define-key map "\C-m" 'pages-directory-goto) (define-key map "\C-c\C-p\C-a" 'add-new-page) - (define-key map [mouse-2] 'pages-directory-goto-with-mouse) + (define-key map [mouse-2] 'pages-directory-goto) map) "Keymap for the pages-directory-buffer.") -(defvaralias 'pages-directory-map 'pages-directory-mode-map) (defvar original-page-delimiter "^\f" "Default page delimiter.") @@ -512,6 +507,9 @@ resets the page-delimiter to the original value." ;;; Pages directory main definitions +(defvar pages-buffer-original-position) +(defvar pages-buffer-original-page) + (defun pages-directory (pages-list-all-headers-p count-lines-p &optional regexp) "Display a directory of the page headers in a temporary buffer. @@ -573,7 +571,6 @@ directory for only the accessible portion of the buffer." (let ((pages-target-buffer (current-buffer)) (pages-directory-buffer (concat pages-directory-prefix " " (buffer-name))) - (linenum 1) (pages-buffer-original-position (point)) (pages-buffer-original-page 0)) @@ -644,10 +641,6 @@ directory for only the accessible portion of the buffer." 1 pages-buffer-original-page)))) -(defvar pages-buffer-original-position) -(defvar pages-buffer-original-page) -(defvar pages-buffer-original-page) - (defun pages-copy-header-and-position (count-lines-p) "Copy page header and its position to the Pages Directory. Only arg non-nil, count lines in page and insert before header. @@ -701,16 +694,13 @@ Used by `pages-directory' function." Move point to one of the lines in this buffer, then use \\[pages-directory-goto] to go to the same line in the pages buffer." - (make-local-variable 'pages-buffer) - (make-local-variable 'pages-pos-list) (make-local-variable 'pages-directory-buffer-narrowing-p)) -(defun pages-directory-goto () +(defun pages-directory-goto (&optional event) "Go to the corresponding line in the pages buffer." - -;;; This function is mostly a copy of `occur-mode-goto-occurrence' - - (interactive) + ;; This function is mostly a copy of `occur-mode-goto-occurrence' + (interactive "@e") + (if event (mouse-set-point event)) (if (or (not pages-buffer) (not (buffer-name pages-buffer))) (progn @@ -724,18 +714,13 @@ to the same line in the pages buffer." (narrowing-p pages-directory-buffer-narrowing-p)) (pop-to-buffer pages-buffer) (widen) - (if end-of-directory-p - (goto-char (point-max)) - (goto-char (marker-position pos))) + (goto-char (if end-of-directory-p + (point-max) + (marker-position pos))) (if narrowing-p (narrow-to-page)))) -(defun pages-directory-goto-with-mouse (event) - "Go to the corresponding line under the mouse pointer in the pages buffer." - (interactive "e") - (with-current-buffer (window-buffer (posn-window (event-end event))) - (save-excursion - (goto-char (posn-point (event-end event))) - (pages-directory-goto)))) +(define-obsolete-function-alias 'pages-directory-goto-with-mouse + #'pages-directory-goto "26.1") ;;; The `pages-directory-for-addresses' function and ancillary code diff --git a/lisp/textmodes/reftex-ref.el b/lisp/textmodes/reftex-ref.el index 98fb8f5d700..eb8d98c84be 100644 --- a/lisp/textmodes/reftex-ref.el +++ b/lisp/textmodes/reftex-ref.el @@ -314,7 +314,7 @@ also applies `reftex-translate-to-ascii-function' to the string." (save-match-data (cond ((equal letter "f") - (file-name-base)) + (file-name-base (buffer-file-name))) ((equal letter "F") (let ((masterdir (file-name-directory (reftex-TeX-master-file))) (file (file-name-sans-extension (buffer-file-name)))) diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el index 7f4c9b0b24a..83bfc79d6a4 100644 --- a/lisp/textmodes/remember.el +++ b/lisp/textmodes/remember.el @@ -402,11 +402,19 @@ exists) might be changed." :type 'string :group 'remember) +(defcustom remember-time-format "%a %b %d %H:%M:%S %Y" + "The format for time stamp, passed to `format-time-string'. +The default emulates `current-time-string' for backward compatibility." + :type 'string + :group 'remember + :version "27.1") + (defun remember-append-to-file () "Remember, with description DESC, the given TEXT." (let* ((text (buffer-string)) (desc (remember-buffer-desc)) - (remember-text (concat "\n" remember-leader-text (current-time-string) + (remember-text (concat "\n" remember-leader-text + (format-time-string remember-time-format) " (" desc ")\n\n" text (save-excursion (goto-char (point-max)) (if (bolp) nil "\n")))) diff --git a/lisp/textmodes/rst.el b/lisp/textmodes/rst.el index 87ea1e827d5..c93e4e474cb 100644 --- a/lisp/textmodes/rst.el +++ b/lisp/textmodes/rst.el @@ -112,27 +112,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Support for `testcover' -(when (and (boundp 'testcover-1value-functions) - (boundp 'testcover-compose-functions)) - ;; Below `lambda' is used in a loop with varying parameters and is thus not - ;; 1valued. - (setq testcover-1value-functions - (delq 'lambda testcover-1value-functions)) - (add-to-list 'testcover-compose-functions 'lambda)) - -(defun rst-testcover-defcustom () - "Remove all customized variables from `testcover-module-constants'. -This seems to be a bug in `testcover': `defcustom' variables are -considered constants. Revert it with this function after each `defcustom'." - (when (boundp 'testcover-module-constants) - (setq testcover-module-constants - (delq nil - (mapcar - #'(lambda (sym) - (if (not (plist-member (symbol-plist sym) 'standard-value)) - sym)) - testcover-module-constants))))) - (defun rst-testcover-add-compose (fun) "Add FUN to `testcover-compose-functions'." (when (boundp 'testcover-compose-functions) @@ -1344,7 +1323,6 @@ This inherits from Text mode.") The hook for `text-mode' is run before this one." :group 'rst :type '(hook)) -(rst-testcover-defcustom) ;; Pull in variable definitions silencing byte-compiler. (require 'newcomment) @@ -1541,7 +1519,6 @@ file." (const :tag "Underline only" simple)) (integer :tag "Indentation for overline and underline type" :value 0)))) -(rst-testcover-defcustom) ;; FIXME: Rename this to `rst-over-and-under-default-indent' and set default to ;; 0 because the effect of 1 is probably surprising in the few cases @@ -1558,7 +1535,6 @@ found in the buffer are to be used but the indentation for over-and-under adornments is inconsistent across the buffer." :group 'rst-adjust :type '(integer)) -(rst-testcover-defcustom) (defun rst-new-preferred-hdr (seen prev) ;; testcover: ok. @@ -1997,7 +1973,6 @@ b. a negative numerical argument, which generally inverts the :group 'rst-adjust :type '(hook) :package-version '(rst . "1.1.0")) -(rst-testcover-defcustom) (defcustom rst-new-adornment-down nil "Controls level of new adornment for section headers." @@ -2006,7 +1981,6 @@ b. a negative numerical argument, which generally inverts the (const :tag "Same level as previous one" nil) (const :tag "One level down relative to the previous one" t)) :package-version '(rst . "1.1.0")) -(rst-testcover-defcustom) (defun rst-adjust-adornment (pfxarg) "Call `rst-adjust-section' interactively. @@ -2429,7 +2403,6 @@ also arranged by `rst-insert-list-new-tag'." :tag (char-to-string char) char)) rst-bullets))) :package-version '(rst . "1.1.0")) -(rst-testcover-defcustom) (defun rst-insert-list-continue (ind tag tab prefer-roman) ;; testcover: ok. @@ -2666,7 +2639,6 @@ section headers at all." Also used for formatting insertion, when numbering is disabled." :type 'integer :group 'rst-toc) -(rst-testcover-defcustom) (defcustom rst-toc-insert-style 'fixed "Insertion style for table-of-contents. @@ -2681,19 +2653,16 @@ indentation style: (const aligned) (const listed)) :group 'rst-toc) -(rst-testcover-defcustom) (defcustom rst-toc-insert-number-separator " " "Separator that goes between the TOC number and the title." :type 'string :group 'rst-toc) -(rst-testcover-defcustom) (defcustom rst-toc-insert-max-level nil "If non-nil, maximum depth of the inserted TOC." :type '(choice (const nil) integer) :group 'rst-toc) -(rst-testcover-defcustom) (defconst rst-toc-link-keymap (let ((map (make-sparse-keymap))) @@ -3158,35 +3127,30 @@ These indentation widths can be customized here." "Indentation when there is no more indentation point given." :group 'rst-indent :type '(integer)) -(rst-testcover-defcustom) (defcustom rst-indent-field 3 "Indentation for first line after a field or 0 to always indent for content." :group 'rst-indent :package-version '(rst . "1.1.0") :type '(integer)) -(rst-testcover-defcustom) (defcustom rst-indent-literal-normal 3 "Default indentation for literal block after a markup on an own line." :group 'rst-indent :package-version '(rst . "1.1.0") :type '(integer)) -(rst-testcover-defcustom) (defcustom rst-indent-literal-minimized 2 "Default indentation for literal block after a minimized markup." :group 'rst-indent :package-version '(rst . "1.1.0") :type '(integer)) -(rst-testcover-defcustom) (defcustom rst-indent-comment 3 "Default indentation for first line of a comment." :group 'rst-indent :package-version '(rst . "1.1.0") :type '(integer)) -(rst-testcover-defcustom) ;; FIXME: Must consider other tabs: ;; * Line blocks @@ -3636,7 +3600,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too." :version "24.1" :group 'rst-faces :type '(face)) -(rst-testcover-defcustom) (make-obsolete-variable 'rst-block-face "customize the face `rst-block' instead." "24.1") @@ -3651,7 +3614,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too." :version "24.1" :group 'rst-faces :type '(face)) -(rst-testcover-defcustom) (make-obsolete-variable 'rst-external-face "customize the face `rst-external' instead." "24.1") @@ -3666,7 +3628,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too." :version "24.1" :group 'rst-faces :type '(face)) -(rst-testcover-defcustom) (make-obsolete-variable 'rst-definition-face "customize the face `rst-definition' instead." "24.1") @@ -3683,7 +3644,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too." "Directives and roles." :group 'rst-faces :type '(face)) -(rst-testcover-defcustom) (make-obsolete-variable 'rst-directive-face "customize the face `rst-directive' instead." "24.1") @@ -3698,7 +3658,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too." :version "24.1" :group 'rst-faces :type '(face)) -(rst-testcover-defcustom) (make-obsolete-variable 'rst-comment-face "customize the face `rst-comment' instead." "24.1") @@ -3713,7 +3672,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too." :version "24.1" :group 'rst-faces :type '(face)) -(rst-testcover-defcustom) (make-obsolete-variable 'rst-emphasis1-face "customize the face `rst-emphasis1' instead." "24.1") @@ -3727,7 +3685,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too." "Double emphasis." :group 'rst-faces :type '(face)) -(rst-testcover-defcustom) (make-obsolete-variable 'rst-emphasis2-face "customize the face `rst-emphasis2' instead." "24.1") @@ -3742,7 +3699,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too." :version "24.1" :group 'rst-faces :type '(face)) -(rst-testcover-defcustom) (make-obsolete-variable 'rst-literal-face "customize the face `rst-literal' instead." "24.1") @@ -3757,7 +3713,6 @@ Region is from BEG to END. With WITH-EMPTY prefix empty lines too." :version "24.1" :group 'rst-faces :type '(face)) -(rst-testcover-defcustom) (make-obsolete-variable 'rst-reference-face "customize the face `rst-reference' instead." "24.1") @@ -3840,7 +3795,6 @@ of your own." (const :tag "transitions" t) (const :tag "section title adornment" nil)) :value-type (face))) -(rst-testcover-defcustom) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -4337,7 +4291,6 @@ string)) to be used for converting the document." (string :tag "Options")))) :group 'rst-compile :package-version "1.2.0") -(rst-testcover-defcustom) ;; FIXME: Must be defcustom. (defvar rst-compile-primary-toolset 'html diff --git a/lisp/textmodes/texinfo.el b/lisp/textmodes/texinfo.el index c2ceee6e6b7..16399bd9fd7 100644 --- a/lisp/textmodes/texinfo.el +++ b/lisp/textmodes/texinfo.el @@ -610,7 +610,6 @@ value of `texinfo-mode-hook'." (setq font-lock-defaults '(texinfo-font-lock-keywords nil nil nil backward-paragraph)) (setq-local syntax-propertize-function texinfo-syntax-propertize-function) - (setq-local parse-sexp-lookup-properties t) (setq-local add-log-current-defun-function #'texinfo-current-defun-name) ;; Outline settings. diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el index 7fe99b0714c..4612e95bb0e 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el @@ -42,6 +42,9 @@ ;; beginning-op Function to call to skip to the beginning of a "thing". ;; end-op Function to call to skip to the end of a "thing". ;; +;; For simple things, defined as sequences of specific kinds of characters, +;; use macro define-thing-chars. +;; ;; Reliance on existing operators means that many `things' can be accessed ;; without further code: eg. ;; (thing-at-point 'line) @@ -237,21 +240,28 @@ The bounds of THING are determined by `bounds-of-thing-at-point'." (put 'defun 'end-op 'end-of-defun) (put 'defun 'forward-op 'end-of-defun) +;; Things defined by sets of characters + +(defmacro define-thing-chars (thing chars) + "Define THING as a sequence of CHARS. +E.g.: +\(define-thing-chars twitter-screen-name \"[:alnum:]_\")" + `(progn + (put ',thing 'end-op + (lambda () + (re-search-forward (concat "\\=[" ,chars "]*") nil t))) + (put ',thing 'beginning-op + (lambda () + (if (re-search-backward (concat "[^" ,chars "]") nil t) + (forward-char) + (goto-char (point-min))))))) + ;; Filenames (defvar thing-at-point-file-name-chars "-~/[:alnum:]_.${}#%,:" "Characters allowable in filenames.") -(put 'filename 'end-op - (lambda () - (re-search-forward (concat "\\=[" thing-at-point-file-name-chars "]*") - nil t))) -(put 'filename 'beginning-op - (lambda () - (if (re-search-backward (concat "[^" thing-at-point-file-name-chars "]") - nil t) - (forward-char) - (goto-char (point-min))))) +(define-thing-chars filename thing-at-point-file-name-chars) ;; URIs diff --git a/lisp/time.el b/lisp/time.el index 9e7bd08b85a..ab6b5b96328 100644 --- a/lisp/time.el +++ b/lisp/time.el @@ -585,7 +585,7 @@ For example, the Unix uptime command format is \"%D, %z%2h:%.2m\"." (let ((str (format-seconds (or format "%Y, %D, %H, %M, %z%S") (float-time - (time-subtract (current-time) before-init-time))))) + (time-subtract nil before-init-time))))) (if (called-interactively-p 'interactive) (message "%s" str) str))) diff --git a/lisp/tooltip.el b/lisp/tooltip.el index ac26f86ac9d..81df229a132 100644 --- a/lisp/tooltip.el +++ b/lisp/tooltip.el @@ -155,6 +155,18 @@ This variable is obsolete; instead of setting it to t, disable (make-obsolete-variable 'tooltip-use-echo-area "disable Tooltip mode instead" "24.1" 'set) +(defcustom tooltip-resize-echo-area nil + "If non-nil, using the echo area for tooltips will resize the echo area. +By default, when the echo area is used for displaying tooltips, +the tooltip text is truncated if it exceeds a single screen line. +When this variable is non-nil, the text is not truncated; instead, +the echo area is resized as needed to accommodate the full text +of the tooltip. +This variable has effect only on GUI frames." + :type 'boolean + :group 'tooltip + :version "27.1") + ;;; Variables that are not customizable. @@ -347,7 +359,8 @@ It is also called if Tooltip mode is on, for text-only displays." (current-message)))) (setq tooltip-previous-message (current-message))) (setq tooltip-help-message help) - (let ((message-truncate-lines t) + (let ((message-truncate-lines + (or (not (display-graphic-p)) (not tooltip-resize-echo-area))) (message-log-max nil)) (message "%s" help))) ((stringp tooltip-previous-message) diff --git a/lisp/type-break.el b/lisp/type-break.el index 2c928e9db1e..98947bac272 100644 --- a/lisp/type-break.el +++ b/lisp/type-break.el @@ -376,7 +376,7 @@ problems." (if (and type-break-time-last-break (< (setq diff (type-break-time-difference type-break-time-last-break - (current-time))) + nil)) type-break-interval)) ;; Use the file's value. (progn @@ -563,7 +563,7 @@ as per the function `type-break-schedule'." (cond (good-interval (let ((break-secs (type-break-time-difference - start-time (current-time)))) + start-time nil))) (cond ((>= break-secs good-interval) (setq continue nil)) @@ -624,7 +624,7 @@ INTERVAL is the full length of an interval (defaults to TIME)." type-break-time-warning-intervals)) (or time - (setq time (type-break-time-difference (current-time) + (setq time (type-break-time-difference nil type-break-time-next-break))) (while (and type-break-current-time-warning-interval @@ -685,7 +685,7 @@ keystroke threshold has been exceeded." (and type-break-good-rest-interval (progn (and (> (type-break-time-difference - type-break-time-last-command (current-time)) + type-break-time-last-command nil) type-break-good-rest-interval) (progn (type-break-keystroke-reset) diff --git a/lisp/url/url-cache.el b/lisp/url/url-cache.el index 632a34cdd9d..309c96cbccf 100644 --- a/lisp/url/url-cache.el +++ b/lisp/url/url-cache.el @@ -206,7 +206,7 @@ If `url-standalone-mode' is non-nil, cached items never expire." (time-add cache-time (seconds-to-time (or expire-time url-cache-expire-time))) - (current-time)))))) + nil))))) (defun url-cache-prune-cache (&optional directory) "Remove all expired files from the cache. diff --git a/lisp/url/url-cookie.el b/lisp/url/url-cookie.el index 8b676f037c6..76c18b756f7 100644 --- a/lisp/url/url-cookie.el +++ b/lisp/url/url-cookie.el @@ -74,6 +74,55 @@ telling Microsoft that." ;; It's completely normal for the cookies file not to exist yet. (load (or fname url-cookie-file) t t)) +(defun url-cookie-parse-file-netscape (filename &optional long-session) + "Load cookies from FILENAME in Netscape/Mozilla format. +When LONG-SESSION is non-nil, session cookies (expiring at t=0 +i.e. 1970-1-1) are loaded as expiring one year from now instead." + (interactive "fLoad Netscape/Mozilla cookie file: ") + (let ((n 0)) + (with-temp-buffer + (insert-file-contents-literally filename) + (goto-char (point-min)) + (when (not (looking-at-p "# Netscape HTTP Cookie File\n")) + (error (format "File %s doesn't look like a netscape cookie file" filename))) + (while (not (eobp)) + (when (not (looking-at-p (rx bol (* space) "#"))) + (let* ((line (buffer-substring (point) (save-excursion (end-of-line) (point)))) + (fields (split-string line "\t"))) + (cond + ;;((>= 1 (length line) 0) + ;; (message "skipping empty line")) + ((= (length fields) 7) + (let ((dom (nth 0 fields)) + ;; (match (nth 1 fields)) + (path (nth 2 fields)) + (secure (string= (nth 3 fields) "TRUE")) + ;; session cookies (expire time = 0) are supposed + ;; to be removed when the browser is closed, but + ;; the main point of loading external cookie is to + ;; reuse a browser session, so to prevent the + ;; cookie from being detected as expired straight + ;; away, make it expire a year from now + (expires (format-time-string + "%d %b %Y %T [GMT]" + (seconds-to-time + (let ((s (string-to-number (nth 4 fields)))) + (if (and (= s 0) long-session) + (seconds-to-time (+ (* 365 24 60 60) (float-time))) + s))))) + (key (nth 5 fields)) + (val (nth 6 fields))) + (cl-incf n) + ;;(message "adding <%s>=<%s> exp=<%s> dom=<%s> path=<%s> sec=%S" key val expires dom path secure) + (url-cookie-store key val expires dom path secure) + )) + (t + (message "ignoring malformed cookie line <%s>" line))))) + (forward-line)) + (when (< 0 n) + (setq url-cookies-changed-since-last-save t)) + (message "added %d cookies from file %s" n filename)))) + (defun url-cookie-clean-up (&optional secure) (let ((var (if secure 'url-cookie-secure-storage 'url-cookie-storage)) new new-cookies) diff --git a/lisp/url/url.el b/lisp/url/url.el index 20c57115426..ea581010178 100644 --- a/lisp/url/url.el +++ b/lisp/url/url.el @@ -259,8 +259,7 @@ how long to wait for a response before giving up." ;; process output. (while (and (not retrieval-done) (or (not timeout) - (< (float-time (time-subtract - (current-time) start-time)) + (< (float-time (time-subtract nil start-time)) timeout))) (url-debug 'retrieval "Spinning in url-retrieve-synchronously: %S (%S)" diff --git a/lisp/vc/ediff-wind.el b/lisp/vc/ediff-wind.el index 079e195291d..67e9bf2d9de 100644 --- a/lisp/vc/ediff-wind.el +++ b/lisp/vc/ediff-wind.el @@ -64,10 +64,10 @@ (defun ediff-choose-window-setup-function-automatically () (declare (obsolete ediff-setup-windows-default "24.3")) (if (ediff-window-display-p) - 'ediff-setup-windows-multiframe - 'ediff-setup-windows-plain)) + #'ediff-setup-windows-multiframe + #'ediff-setup-windows-plain)) -(defcustom ediff-window-setup-function 'ediff-setup-windows-default +(defcustom ediff-window-setup-function #'ediff-setup-windows-default "Function called to set up windows. Ediff provides a choice of three functions: (1) `ediff-setup-windows-multiframe', which sets the control panel @@ -132,7 +132,7 @@ provided functions are written." (Ancestor . ediff-window-Ancestor))) -(defcustom ediff-split-window-function 'split-window-vertically +(defcustom ediff-split-window-function #'split-window-vertically "The function used to split the main window between buffer-A and buffer-B. You can set it to a horizontal split instead of the default vertical split by setting this variable to `split-window-horizontally'. @@ -145,7 +145,7 @@ In this case, Ediff will use those frames to display these buffers." function) :group 'ediff-window) -(defcustom ediff-merge-split-window-function 'split-window-horizontally +(defcustom ediff-merge-split-window-function #'split-window-horizontally "The function used to split the main window between buffer-A and buffer-B. You can set it to a vertical split instead of the default horizontal split by setting this variable to `split-window-vertically'. @@ -212,7 +212,7 @@ responsibility." :type 'boolean :group 'ediff-window) -(defcustom ediff-control-frame-position-function 'ediff-make-frame-position +(defcustom ediff-control-frame-position-function #'ediff-make-frame-position "Function to call to determine the desired location for the control panel. Expects three parameters: the control buffer, the desired width and height of the control frame. It returns an association list @@ -260,7 +260,7 @@ customization of the default." display off.") (ediff-defvar-local ediff-wide-display-frame nil "Frame to be used for wide display.") -(ediff-defvar-local ediff-make-wide-display-function 'ediff-make-wide-display +(ediff-defvar-local ediff-make-wide-display-function #'ediff-make-wide-display "The value is a function that is called to create a wide display. The function is called without arguments. It should resize the frame in which buffers A, B, and C are to be displayed, and it should save the old @@ -336,11 +336,11 @@ into icons, regardless of the window manager." ;; in case user did a no-no on a tty (or (ediff-window-display-p) - (setq ediff-window-setup-function 'ediff-setup-windows-plain)) + (setq ediff-window-setup-function #'ediff-setup-windows-plain)) (or (ediff-keep-window-config control-buffer) (funcall - (ediff-with-current-buffer control-buffer ediff-window-setup-function) + (with-current-buffer control-buffer ediff-window-setup-function) buffer-A buffer-B buffer-C control-buffer)) (run-hooks 'ediff-after-setup-windows-hook)) @@ -354,7 +354,7 @@ into icons, regardless of the window manager." ;; Usually used without windowing systems ;; With windowing, we want to use dedicated frames. (defun ediff-setup-windows-plain (buffer-A buffer-B buffer-C control-buffer) - (ediff-with-current-buffer control-buffer + (with-current-buffer control-buffer (setq ediff-multiframe nil)) (if ediff-merge-job (ediff-setup-windows-plain-merge @@ -368,14 +368,14 @@ into icons, regardless of the window manager." ;; skip dedicated and unsplittable frames (ediff-destroy-control-frame control-buffer) (let ((window-min-height 1) - (with-Ancestor-p (ediff-with-current-buffer control-buffer + (with-Ancestor-p (with-current-buffer control-buffer ediff-merge-with-ancestor-job)) split-window-function merge-window-share merge-window-lines - (buf-Ancestor (ediff-with-current-buffer control-buffer + (buf-Ancestor (with-current-buffer control-buffer ediff-ancestor-buffer)) wind-A wind-B wind-C wind-Ancestor) - (ediff-with-current-buffer control-buffer + (with-current-buffer control-buffer (setq merge-window-share ediff-merge-window-share ;; this lets us have local versions of ediff-split-window-function split-window-function ediff-split-window-function)) @@ -419,7 +419,7 @@ into icons, regardless of the window manager." (switch-to-buffer buf-B) (setq wind-B (selected-window)) - (ediff-with-current-buffer control-buffer + (with-current-buffer control-buffer (setq ediff-window-A wind-A ediff-window-B wind-B ediff-window-C wind-C @@ -438,7 +438,7 @@ into icons, regardless of the window manager." split-window-function wind-width-or-height three-way-comparison wind-A-start wind-B-start wind-A wind-B wind-C) - (ediff-with-current-buffer control-buffer + (with-current-buffer control-buffer (setq wind-A-start (ediff-overlay-start (ediff-get-value-according-to-buffer-type 'A ediff-narrow-bounds)) @@ -464,7 +464,7 @@ into icons, regardless of the window manager." (setq wind-A (selected-window)) (if three-way-comparison (setq wind-width-or-height - (/ (if (eq split-window-function 'split-window-vertically) + (/ (if (eq split-window-function #'split-window-vertically) (window-height wind-A) (window-width wind-A)) 3))) @@ -489,7 +489,7 @@ into icons, regardless of the window manager." (switch-to-buffer buf-C) (setq wind-C (selected-window)))) - (ediff-with-current-buffer control-buffer + (with-current-buffer control-buffer (setq ediff-window-A wind-A ediff-window-B wind-B ediff-window-C wind-C)) @@ -508,23 +508,23 @@ into icons, regardless of the window manager." ;; dispatch an appropriate window setup function (defun ediff-setup-windows-multiframe (buf-A buf-B buf-C control-buf) - (ediff-with-current-buffer control-buf + (with-current-buffer control-buf (setq ediff-multiframe t)) (if ediff-merge-job (ediff-setup-windows-multiframe-merge buf-A buf-B buf-C control-buf) (ediff-setup-windows-multiframe-compare buf-A buf-B buf-C control-buf))) (defun ediff-setup-windows-multiframe-merge (buf-A buf-B buf-C control-buf) -;;; Algorithm: -;;; 1. Never use frames that have dedicated windows in them---it is bad to -;;; destroy dedicated windows. -;;; 2. If A and B are in the same frame but C's frame is different---use one -;;; frame for A and B, and use a separate frame for C. -;;; 3. If C's frame is non-existent, then: if the first suitable -;;; non-dedicated frame is different from A&B's, then use it for C. -;;; Otherwise, put A, B, and C in one frame. -;;; 4. If buffers A, B, C are in separate frames, use them to display these -;;; buffers. + ;; Algorithm: + ;; 1. Never use frames that have dedicated windows in them---it is bad to + ;; destroy dedicated windows. + ;; 2. If A and B are in the same frame but C's frame is different--- use one + ;; frame for A and B and use a separate frame for C. + ;; 3. If C's frame is non-existent, then: if the first suitable + ;; non-dedicated frame is different from A&B's, then use it for C. + ;; Otherwise, put A,B, and C in one frame. + ;; 4. If buffers A, B, C are is separate frames, use them to display these + ;; buffers. ;; Skip dedicated or iconified frames. ;; Unsplittable frames are taken care of later. @@ -534,7 +534,7 @@ into icons, regardless of the window manager." (wind-A (ediff-get-visible-buffer-window buf-A)) (wind-B (ediff-get-visible-buffer-window buf-B)) (wind-C (ediff-get-visible-buffer-window buf-C)) - (buf-Ancestor (ediff-with-current-buffer control-buf + (buf-Ancestor (with-current-buffer control-buf ediff-ancestor-buffer)) (wind-Ancestor (ediff-get-visible-buffer-window buf-Ancestor)) (frame-A (if wind-A (window-frame wind-A))) @@ -543,10 +543,10 @@ into icons, regardless of the window manager." (frame-Ancestor (if wind-Ancestor (window-frame wind-Ancestor))) ;; on wide display, do things in one frame (force-one-frame - (ediff-with-current-buffer control-buf ediff-wide-display-p)) + (with-current-buffer control-buf ediff-wide-display-p)) ;; this lets us have local versions of ediff-split-window-function (split-window-function - (ediff-with-current-buffer control-buf ediff-split-window-function)) + (with-current-buffer control-buf ediff-split-window-function)) (orig-wind (selected-window)) (orig-frame (selected-frame)) (use-same-frame (or force-one-frame @@ -568,11 +568,11 @@ into icons, regardless of the window manager." ;; use-same-frame-for-AB implies wind A and B are ok for display (use-same-frame-for-AB (and (not use-same-frame) (eq frame-A frame-B))) - (merge-window-share (ediff-with-current-buffer control-buf + (merge-window-share (with-current-buffer control-buf ediff-merge-window-share)) merge-window-lines designated-minibuffer-frame ; ediff-merge-with-ancestor-job - (with-Ancestor-p (ediff-with-current-buffer control-buf + (with-Ancestor-p (with-current-buffer control-buf ediff-merge-with-ancestor-job)) (done-Ancestor (not with-Ancestor-p)) done-A done-B done-C) @@ -726,7 +726,7 @@ into icons, regardless of the window manager." (switch-to-buffer buf-Ancestor) (setq wind-Ancestor (selected-window)))) - (ediff-with-current-buffer control-buf + (with-current-buffer control-buf (setq ediff-window-A wind-A ediff-window-B wind-B ediff-window-C wind-C @@ -740,21 +740,17 @@ into icons, regardless of the window manager." ;; Window setup for all comparison jobs, including 3way comparisons (defun ediff-setup-windows-multiframe-compare (buf-A buf-B buf-C control-buf) -;;; Algorithm: -;;; If a buffer is seen in a frame, use that frame for that buffer. -;;; If it is not seen, use the current frame. -;;; If both buffers are not seen, they share the current frame. If one -;;; of the buffers is not seen, it is placed in the current frame (where -;;; ediff started). If that frame is displaying the other buffer, it is -;;; shared between the two buffers. -;;; However, if we decide to put both buffers in one frame -;;; and the selected frame isn't splittable, we create a new frame and -;;; put both buffers there, event if one of this buffers is visible in -;;; another frame. - - ;; Skip dedicated or iconified frames. - ;; Unsplittable frames are taken care of later. - (ediff-skip-unsuitable-frames 'ok-unsplittable) + ;; Algorithm: + ;; If a buffer is seen in a frame, use that frame for that buffer. + ;; If it is not seen, use the current frame. + ;; If both buffers are not seen, they share the current frame. If one + ;; of the buffers is not seen, it is placed in the current frame (where + ;; ediff started). If that frame is displaying the other buffer, it is + ;; shared between the two buffers. + ;; However, if we decide to put both buffers in one frame + ;; and the selected frame isn't splittable, we create a new frame and + ;; put both buffers there, event if one of this buffers is visible in + ;; another frame. (let* ((window-min-height 1) (wind-A (ediff-get-visible-buffer-window buf-A)) @@ -763,17 +759,16 @@ into icons, regardless of the window manager." (frame-A (if wind-A (window-frame wind-A))) (frame-B (if wind-B (window-frame wind-B))) (frame-C (if wind-C (window-frame wind-C))) - (ctl-frame-exists-p (ediff-with-current-buffer control-buf + (ctl-frame-exists-p (with-current-buffer control-buf (frame-live-p ediff-control-frame))) ;; on wide display, do things in one frame (force-one-frame - (ediff-with-current-buffer control-buf ediff-wide-display-p)) + (with-current-buffer control-buf ediff-wide-display-p)) ;; this lets us have local versions of ediff-split-window-function (split-window-function - (ediff-with-current-buffer control-buf ediff-split-window-function)) + (with-current-buffer control-buf ediff-split-window-function)) (three-way-comparison - (ediff-with-current-buffer control-buf ediff-3way-comparison-job)) - (orig-wind (selected-window)) + (with-current-buffer control-buf ediff-3way-comparison-job)) (use-same-frame (or force-one-frame (eq frame-A frame-B) (not (ediff-window-ok-for-display wind-A)) @@ -792,10 +787,9 @@ into icons, regardless of the window manager." (or ctl-frame-exists-p (eq frame-B (selected-frame)))))) wind-A-start wind-B-start - designated-minibuffer-frame - done-A done-B done-C) + designated-minibuffer-frame) - (ediff-with-current-buffer control-buf + (with-current-buffer control-buf (setq wind-A-start (ediff-overlay-start (ediff-get-value-according-to-buffer-type 'A ediff-narrow-bounds)) @@ -803,30 +797,6 @@ into icons, regardless of the window manager." (ediff-get-value-according-to-buffer-type 'B ediff-narrow-bounds)))) - (if (and (window-live-p wind-A) (null use-same-frame)) ; buf-A on its own - (progn - ;; buffer buf-A is seen in live wind-A - (select-window wind-A) ; must be displaying buf-A - (delete-other-windows) - (setq wind-A (selected-window)) - (setq done-A t))) - - (if (and (window-live-p wind-B) (null use-same-frame)) ; buf B on its own - (progn - ;; buffer buf-B is seen in live wind-B - (select-window wind-B) ; must be displaying buf-B - (delete-other-windows) - (setq wind-B (selected-window)) - (setq done-B t))) - - (if (and (window-live-p wind-C) (null use-same-frame)) ; buf C on its own - (progn - ;; buffer buf-C is seen in live wind-C - (select-window wind-C) ; must be displaying buf-C - (delete-other-windows) - (setq wind-C (selected-window)) - (setq done-C t))) - (if use-same-frame (let (wind-width-or-height) ; this affects 3way setups only (if (and (eq frame-A frame-B) (frame-live-p frame-A)) @@ -840,7 +810,7 @@ into icons, regardless of the window manager." (if three-way-comparison (setq wind-width-or-height (/ - (if (eq split-window-function 'split-window-vertically) + (if (eq split-window-function #'split-window-vertically) (window-height wind-A) (window-width wind-A)) 3))) @@ -857,46 +827,57 @@ into icons, regardless of the window manager." (if (memq (selected-window) (list wind-A wind-B)) (other-window 1)) (switch-to-buffer buf-C) - (setq wind-C (selected-window)))) - (setq done-A t - done-B t - done-C t) - )) - - (or done-A ; Buf A to be set in its own frame - ;;; or it was set before because use-same-frame = 1 - (progn - ;; Buf-A was not set up yet as it wasn't visible, - ;; and use-same-frame = nil - (select-window orig-wind) - (delete-other-windows) - (switch-to-buffer buf-A) - (setq wind-A (selected-window)) - )) - (or done-B ; Buf B to be set in its own frame - ;;; or it was set before because use-same-frame = 1 - (progn - ;; Buf-B was not set up yet as it wasn't visible, - ;; and use-same-frame = nil - (select-window orig-wind) - (delete-other-windows) - (switch-to-buffer buf-B) - (setq wind-B (selected-window)) - )) - - (if three-way-comparison - (or done-C ; Buf C to be set in its own frame - ;;; or it was set before because use-same-frame = 1 + (setq wind-C (selected-window))))) + + (if (window-live-p wind-A) ; buf-A on its own + (progn + ;; buffer buf-A is seen in live wind-A + (select-window wind-A) ; must be displaying buf-A + (delete-other-windows) + (setq wind-A (selected-window))) ;FIXME: Why? + ;; Buf-A was not set up yet as it wasn't visible, + ;; and use-same-frame = nil + ;; Skip dedicated or iconified frames. + ;; Unsplittable frames are taken care of later. + (ediff-skip-unsuitable-frames 'ok-unsplittable) + (delete-other-windows) + (switch-to-buffer buf-A) + (setq wind-A (selected-window))) + + (if (window-live-p wind-B) ; buf B on its own + (progn + ;; buffer buf-B is seen in live wind-B + (select-window wind-B) ; must be displaying buf-B + (delete-other-windows) + (setq wind-B (selected-window))) ;FIXME: Why? + ;; Buf-B was not set up yet as it wasn't visible, + ;; and use-same-frame = nil + ;; Skip dedicated or iconified frames. + ;; Unsplittable frames are taken care of later. + (ediff-skip-unsuitable-frames 'ok-unsplittable) + (delete-other-windows) + (switch-to-buffer buf-B) + (setq wind-B (selected-window))) + + (if (window-live-p wind-C) ; buf C on its own + (progn + ;; buffer buf-C is seen in live wind-C + (select-window wind-C) ; must be displaying buf-C + (delete-other-windows) + (setq wind-C (selected-window))) ;FIXME: Why? + (if three-way-comparison (progn ;; Buf-C was not set up yet as it wasn't visible, ;; and use-same-frame = nil - (select-window orig-wind) + ;; Skip dedicated or iconified frames. + ;; Unsplittable frames are taken care of later. + (ediff-skip-unsuitable-frames 'ok-unsplittable) (delete-other-windows) (switch-to-buffer buf-C) (setq wind-C (selected-window)) - ))) + )))) - (ediff-with-current-buffer control-buf + (with-current-buffer control-buf (setq ediff-window-A wind-A ediff-window-B wind-B ediff-window-C wind-C) @@ -915,9 +896,9 @@ into icons, regardless of the window manager." (ediff-setup-control-frame control-buf designated-minibuffer-frame) )) -;; skip unsplittable frames and frames that have dedicated windows. -;; create a new splittable frame if none is found (defun ediff-skip-unsuitable-frames (&optional ok-unsplittable) + "Skip unsplittable frames and frames that have dedicated windows. +create a new splittable frame if none is found." (if (ediff-window-display-p) (let ((wind-frame (window-frame)) seen-windows) @@ -977,14 +958,14 @@ into icons, regardless of the window manager." ;; user-grabbed-mouse fheight fwidth adjusted-parameters) - (ediff-with-current-buffer ctl-buffer + (with-current-buffer ctl-buffer (if (and (featurep 'xemacs) (featurep 'menubar)) (set-buffer-menubar nil)) ;;(setq user-grabbed-mouse (ediff-user-grabbed-mouse)) (run-hooks 'ediff-before-setup-control-frame-hook)) - (setq old-ctl-frame (ediff-with-current-buffer ctl-buffer ediff-control-frame)) - (ediff-with-current-buffer ctl-buffer + (setq old-ctl-frame (with-current-buffer ctl-buffer ediff-control-frame)) + (with-current-buffer ctl-buffer (setq ctl-frame (if (frame-live-p old-ctl-frame) old-ctl-frame (make-frame ediff-control-frame-parameters)) @@ -1004,7 +985,7 @@ into icons, regardless of the window manager." ;; must be before ediff-setup-control-buffer ;; just a precaution--we should be in ctl-buffer already - (ediff-with-current-buffer ctl-buffer + (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 @@ -1103,12 +1084,12 @@ into icons, regardless of the window manager." (not (eq ediff-grab-mouse t))))) (when (featurep 'xemacs) - (ediff-with-current-buffer ctl-buffer + (with-current-buffer ctl-buffer (make-local-hook 'select-frame-hook) (add-hook 'select-frame-hook - 'ediff-xemacs-select-frame-hook nil 'local))) + #'ediff-xemacs-select-frame-hook nil 'local))) - (ediff-with-current-buffer ctl-buffer + (with-current-buffer ctl-buffer (run-hooks 'ediff-after-setup-control-frame-hook)))) @@ -1128,7 +1109,7 @@ into icons, regardless of the window manager." ;; finds a good place to clip control frame (defun ediff-make-frame-position (ctl-buffer ctl-frame-width ctl-frame-height) - (ediff-with-current-buffer ctl-buffer + (with-current-buffer ctl-buffer (let* ((frame-A (window-frame ediff-window-A)) (frame-A-parameters (frame-parameters frame-A)) (frame-A-top (eval (cdr (assoc 'top frame-A-parameters)))) @@ -1382,12 +1363,4 @@ It assumes that it is called from within the control buffer." (provide 'ediff-wind) - - -;; Local Variables: -;; eval: (put 'ediff-defvar-local 'lisp-indent-hook 'defun) -;; eval: (put 'ediff-with-current-buffer 'lisp-indent-hook 1) -;; eval: (put 'ediff-with-current-buffer 'edebug-form-spec '(form body)) -;; End: - ;;; ediff-wind.el ends here diff --git a/lisp/vc/log-edit.el b/lisp/vc/log-edit.el index 438ef117da6..89b6201bab2 100644 --- a/lisp/vc/log-edit.el +++ b/lisp/vc/log-edit.el @@ -623,7 +623,7 @@ Also saves its contents in the comment history and hides (setq buffer-read-only nil) (erase-buffer) (cvs-insert-strings files) - (setq buffer-read-only t) + (special-mode) (goto-char (point-min)) (save-selected-window (cvs-pop-to-buffer-same-frame buf) diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index b439fe736d5..db595331bbd 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -554,11 +554,15 @@ If a prefix argument is given, move by that many lines." (defun vc-dir-mark-unmark (mark-unmark-function) (if (use-region-p) - (let (;; (firstl (line-number-at-pos (region-beginning))) + (let ((processed-line nil) (lastl (line-number-at-pos (region-end)))) (save-excursion (goto-char (region-beginning)) - (while (<= (line-number-at-pos) lastl) + (while (and (<= (line-number-at-pos) lastl) + ;; We make sure to not get stuck processing the + ;; same line in an infinite loop. + (not (eq processed-line (line-number-at-pos)))) + (setq processed-line (line-number-at-pos)) (condition-case nil (funcall mark-unmark-function) ;; `vc-dir-mark-file' signals an error if we try marking diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 3bf837caaa8..626cf6165a3 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -857,13 +857,13 @@ It is based on `log-edit-mode', and has Git-specific extensions.") (vc-git-command nil nil file "checkout" "-q" "--"))) (defvar vc-git-error-regexp-alist - '(("^ \\(.+\\) |" 1 nil nil 0)) + '(("^ \\(.+\\)\\> *|" 1 nil nil 0)) "Value of `compilation-error-regexp-alist' in *vc-git* buffers.") ;; To be called via vc-pull from vc.el, which requires vc-dispatcher. (declare-function vc-compilation-mode "vc-dispatcher" (backend)) -(defun vc-git--pushpull (command prompt) +(defun vc-git--pushpull (command prompt extra-args) "Run COMMAND (a string; either push or pull) on the current Git branch. If PROMPT is non-nil, prompt for the Git command to run." (let* ((root (vc-git-root default-directory)) @@ -882,6 +882,7 @@ If PROMPT is non-nil, prompt for the Git command to run." (setq git-program (car args) command (cadr args) args (cddr args))) + (setq args (nconc args extra-args)) (require 'vc-dispatcher) (apply 'vc-do-async-command buffer root git-program command args) (with-current-buffer buffer @@ -889,7 +890,7 @@ If PROMPT is non-nil, prompt for the Git command to run." (vc-compilation-mode 'git) (setq-local compile-command (concat git-program " " command " " - (if args (mapconcat 'identity args " ") ""))) + (mapconcat 'identity args " "))) (setq-local compilation-directory root) ;; Either set `compilation-buffer-name-function' locally to nil ;; or use `compilation-arguments' to set `name-function'. @@ -904,13 +905,13 @@ If PROMPT is non-nil, prompt for the Git command to run." "Pull changes into the current Git branch. Normally, this runs \"git pull\". If PROMPT is non-nil, prompt for the Git command to run." - (vc-git--pushpull "pull" prompt)) + (vc-git--pushpull "pull" prompt '("--stat"))) (defun vc-git-push (prompt) "Push changes from the current Git branch. Normally, this runs \"git push\". If PROMPT is non-nil, prompt for the Git command to run." - (vc-git--pushpull "push" prompt)) + (vc-git--pushpull "push" prompt nil)) (defun vc-git-merge-branch () "Merge changes into the current Git branch. diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index 2deac2aae27..08b1be8f6d3 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -1296,12 +1296,8 @@ REV is the revision to check out into WORKFILE." (vc-hg-command buffer 1 nil "outgoing" "-n" (unless (string= remote-location "") remote-location))) -(defvar vc-hg-error-regexp-alist nil - ;; 'hg pull' does not list modified files, so, for now, the only - ;; benefit of `vc-compilation-mode' is that one can get rid of - ;; *vc-hg* buffer with 'q' or 'z'. - ;; TODO: call 'hg incoming' before pull/merge to get the list of - ;; modified files +(defvar vc-hg-error-regexp-alist + '(("^M \\(.+\\)" 1 nil nil 0)) "Value of `compilation-error-regexp-alist' in *vc-hg* buffers.") (autoload 'vc-do-async-command "vc-dispatcher") @@ -1309,9 +1305,10 @@ REV is the revision to check out into WORKFILE." (defvar compilation-directory) (defvar compilation-arguments) ; defined in compile.el -(defun vc-hg--pushpull (command prompt &optional obsolete) +(defun vc-hg--pushpull (command prompt post-processing &optional obsolete) "Run COMMAND (a string; either push or pull) on the current Hg branch. If PROMPT is non-nil, prompt for the Hg command to run. +POST-PROCESSING is a list of commands to execute after the command. If OBSOLETE is non-nil, behave like the old versions of the Hg push/pull commands, which only operated on marked files." (let (marked-list) @@ -1327,18 +1324,14 @@ commands, which only operated on marked files." (let* ((root (vc-hg-root default-directory)) (buffer (format "*vc-hg : %s*" (expand-file-name root))) (hg-program vc-hg-program) - ;; Fixme: before updating the working copy to the latest - ;; state, should check if it's visiting an old revision. - (args (if (equal command "pull") '("-u")))) + args) ;; If necessary, prompt for the exact command. ;; TODO if pushing, prompt if no default push location - cf bzr. (when prompt (setq args (split-string (read-shell-command (format "Hg %s command: " command) - (format "%s %s%s" hg-program command - (if (not args) "" - (concat " " (mapconcat 'identity args " ")))) + (format "%s %s" hg-program command) 'vc-hg-history) " " t)) (setq hg-program (car args) @@ -1347,10 +1340,17 @@ commands, which only operated on marked files." (apply 'vc-do-async-command buffer root hg-program command args) (with-current-buffer buffer (vc-run-delayed + (dolist (cmd post-processing) + (apply 'vc-do-command buffer nil hg-program nil cmd)) (vc-compilation-mode 'hg) (setq-local compile-command (concat hg-program " " command " " - (if args (mapconcat 'identity args " ") ""))) + (mapconcat 'identity args " ") + (mapconcat (lambda (args) + (concat " && " hg-program " " + (mapconcat 'identity + args " "))) + post-processing ""))) (setq-local compilation-directory root) ;; Either set `compilation-buffer-name-function' locally to nil ;; or use `compilation-arguments' to set `name-function'. @@ -1371,7 +1371,15 @@ specific Mercurial pull command. The default is \"hg pull -u\", which fetches changesets from the default remote repository and then attempts to update the working directory." (interactive "P") - (vc-hg--pushpull "pull" prompt (called-interactively-p 'interactive))) + (vc-hg--pushpull "pull" prompt + ;; Fixme: before updating the working copy to the latest + ;; state, should check if it's visiting an old revision. + ;; post-processing: list modified files and update + ;; NB: this will not work with "pull = --rebase" + ;; or "pull = --update" in hgrc. + '(("--pager" "no" "status" "--rev" "." "--rev" "tip") + ("update")) + (called-interactively-p 'interactive))) (defun vc-hg-push (prompt) "Push changes from the current Mercurial branch. @@ -1381,7 +1389,7 @@ for the Hg command to run. If called interactively with a set of marked Log View buffers, call \"hg push -r REVS\" to push the specified revisions REVS." (interactive "P") - (vc-hg--pushpull "push" prompt (called-interactively-p 'interactive))) + (vc-hg--pushpull "push" prompt nil (called-interactively-p 'interactive))) (defun vc-hg-merge-branch () "Merge incoming changes into the current working directory. diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index 7c502f88df9..44c0c207d67 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -2417,11 +2417,13 @@ When called interactively with a prefix argument, prompt for REMOTE-LOCATION." (defun vc-region-history (from to) "Show the history of the region FROM..TO." (interactive "r") - (let* ((lfrom (line-number-at-pos from)) - (lto (line-number-at-pos (1- to))) + (let* ((lfrom (line-number-at-pos from t)) + (lto (line-number-at-pos (1- to) t)) (file buffer-file-name) (backend (vc-backend file)) (buf (get-buffer-create "*VC-history*"))) + (unless backend + (error "Buffer is not version controlled")) (with-current-buffer buf (setq-local vc-log-view-type 'long)) (vc-call region-history file buf lfrom lto) diff --git a/lisp/w32-fns.el b/lisp/w32-fns.el index b35e6869d2e..18f987e26bd 100644 --- a/lisp/w32-fns.el +++ b/lisp/w32-fns.el @@ -31,13 +31,13 @@ ;;;; Function keys -(declare-function set-message-beep "w32fns.c" (sound)) (declare-function w32-get-locale-info "w32proc.c" (lcid &optional longform)) (declare-function w32-get-valid-locale-ids "w32proc.c" ()) -;; Map all versions of a filename (8.3, longname, mixed case) to the -;; same buffer. -(setq find-file-visit-truename t) +(if (eq system-type 'windows-nt) + ;; Map all versions of a filename (8.3, longname, mixed case) to the + ;; same buffer. + (setq find-file-visit-truename t)) (defun w32-shell-name () "Return the name of the shell being used." @@ -242,7 +242,8 @@ This function is provided for backward compatibility, since (defvaralias 'w32-system-coding-system 'locale-coding-system) ;; Set to a system sound if you want a fancy bell. -(set-message-beep nil) +(if (fboundp 'set-message-beep) ; w32fns.c + (set-message-beep nil)) (defvar w32-charset-info-alist) ; w32font.c @@ -259,47 +260,48 @@ bit output with no translation." (add-to-list 'w32-charset-info-alist (cons xlfd-charset (cons windows-charset codepage)))) -;; The last charset we add becomes the "preferred" charset for the return -;; value from w32-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) -;; 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 "ksc5601.1989" '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 "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) -(w32-add-charset-info "iso8859-2" 'w32-charset-easteurope 28592) -(w32-add-charset-info "iso8859-3" 'w32-charset-turkish 28593) -(w32-add-charset-info "iso8859-4" 'w32-charset-baltic 28594) -(w32-add-charset-info "iso8859-6" 'w32-charset-arabic 28596) -(w32-add-charset-info "iso8859-7" 'w32-charset-greek 28597) -(w32-add-charset-info "iso8859-8" 'w32-charset-hebrew 1255) -(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 "iso8859-5" 'w32-charset-russian 28595) -(w32-add-charset-info "tis620-2533" 'w32-charset-thai 874) -(w32-add-charset-info "windows-1258" '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) - -;; ;; If Unicode Windows charset is not defined, use ansi fonts. -;; (w32-add-charset-info "iso10646-1" 'w32-charset-ansi t)) - -;; Preferred names -(w32-add-charset-info "big5-0" 'w32-charset-chinesebig5 950) -(w32-add-charset-info "gb2312.1980-0" 'w32-charset-gb2312 936) -(w32-add-charset-info "jisx0208-sjis" 'w32-charset-shiftjis 932) -(w32-add-charset-info "ksc5601.1987-0" 'w32-charset-hangeul 949) -(w32-add-charset-info "tis620-0" 'w32-charset-thai 874) -(w32-add-charset-info "iso8859-1" 'w32-charset-ansi 1252) +(when (boundp 'w32-charset-info-alist) + ;; The last charset we add becomes the "preferred" charset for the return + ;; value from w32-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) + ;; 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 "ksc5601.1989" '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 "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) + (w32-add-charset-info "iso8859-2" 'w32-charset-easteurope 28592) + (w32-add-charset-info "iso8859-3" 'w32-charset-turkish 28593) + (w32-add-charset-info "iso8859-4" 'w32-charset-baltic 28594) + (w32-add-charset-info "iso8859-6" 'w32-charset-arabic 28596) + (w32-add-charset-info "iso8859-7" 'w32-charset-greek 28597) + (w32-add-charset-info "iso8859-8" 'w32-charset-hebrew 1255) + (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 "iso8859-5" 'w32-charset-russian 28595) + (w32-add-charset-info "tis620-2533" 'w32-charset-thai 874) + (w32-add-charset-info "windows-1258" '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) + + ;; ;; If Unicode Windows charset is not defined, use ansi fonts. + ;; (w32-add-charset-info "iso10646-1" 'w32-charset-ansi t)) + + ;; Preferred names + (w32-add-charset-info "big5-0" 'w32-charset-chinesebig5 950) + (w32-add-charset-info "gb2312.1980-0" 'w32-charset-gb2312 936) + (w32-add-charset-info "jisx0208-sjis" 'w32-charset-shiftjis 932) + (w32-add-charset-info "ksc5601.1987-0" 'w32-charset-hangeul 949) + (w32-add-charset-info "tis620-0" 'w32-charset-thai 874) + (w32-add-charset-info "iso8859-1" 'w32-charset-ansi 1252)) ;;;; Support for build process diff --git a/lisp/whitespace.el b/lisp/whitespace.el index e78962201b2..c2827d3d518 100644 --- a/lisp/whitespace.el +++ b/lisp/whitespace.el @@ -2,8 +2,8 @@ ;; Copyright (C) 2000-2018 Free Software Foundation, Inc. -;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> -;; Maintainer: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Author: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> +;; Maintainer: Vinicius Jose Latorre <viniciusjl.gnu@gmail.com> ;; Keywords: data, wp ;; Version: 13.2.2 ;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre diff --git a/lisp/woman.el b/lisp/woman.el index 73f18b0dd6a..1a603dba2f0 100644 --- a/lisp/woman.el +++ b/lisp/woman.el @@ -1619,7 +1619,7 @@ decompress the file if appropriate. See the documentation for the (setq woman-buffer-alist (cons (cons file-name bufname) woman-buffer-alist) woman-buffer-number 0))))) - (Man-build-section-alist) + (Man-build-section-list) (Man-build-references-alist) (goto-char (point-min))) diff --git a/lisp/xdg.el b/lisp/xdg.el index 96c43dea172..a896eb855a8 100644 --- a/lisp/xdg.el +++ b/lisp/xdg.el @@ -34,6 +34,7 @@ ;;; Code: (eval-when-compile + (require 'cl-lib) (require 'subr-x)) @@ -212,6 +213,108 @@ Optional argument GROUP defaults to the string \"Desktop Entry\"." (when (null (string-match-p "[^[:blank:]]" (car res))) (pop res)) (nreverse res))) + +;; MIME apps specification +;; https://standards.freedesktop.org/mime-apps-spec/mime-apps-spec-1.0.1.html + +(defvar xdg-mime-table nil + "Table of MIME type to desktop file associations. +The table is an alist with keys being MIME major types (\"application\", +\"audio\", etc.), and values being hash tables. Each hash table has +MIME subtypes as keys and lists of desktop file absolute filenames.") + +(defun xdg-mime-apps-files () + "Return a list of files containing MIME/Desktop associations. +The list is in order of descending priority: user config, then +admin config, and finally system cached associations." + (let ((xdg-data-dirs (xdg-data-dirs)) + (desktop (getenv "XDG_CURRENT_DESKTOP")) + res) + (when desktop + (setq desktop (format "%s-mimeapps.list" desktop))) + (dolist (name (cons "mimeapps.list" desktop)) + (push (expand-file-name name (xdg-config-home)) res) + (push (expand-file-name (format "applications/%s" name) (xdg-data-home)) + res) + (dolist (dir (xdg-config-dirs)) + (push (expand-file-name name dir) res)) + (dolist (dir xdg-data-dirs) + (push (expand-file-name (format "applications/%s" name) dir) res))) + (dolist (dir xdg-data-dirs) + (push (expand-file-name "applications/mimeinfo.cache" dir) res)) + (nreverse res))) + +(defun xdg-mime-collect-associations (mime files) + "Return a list of desktop file names associated with MIME. +The associations are searched in the list of file names FILES, +which is expected to be ordered by priority as in +`xdg-mime-apps-files'." + (let ((regexp (concat (regexp-quote mime) "=\\([^[:cntrl:]]*\\)$")) + res sec defaults added removed cached) + (with-temp-buffer + (dolist (f (reverse files)) + (when (file-readable-p f) + (insert-file-contents-literally f nil nil nil t) + (goto-char (point-min)) + (let (end) + (while (not (or (eobp) end)) + (if (= (following-char) ?\[) + (progn (setq sec (char-after (1+ (point)))) + (forward-line)) + (if (not (looking-at regexp)) + (forward-line) + (dolist (str (xdg-desktop-strings (match-string 1))) + (cl-pushnew str + (cond ((eq sec ?D) defaults) + ((eq sec ?A) added) + ((eq sec ?R) removed) + ((eq sec ?M) cached)) + :test #'equal)) + (while (and (zerop (forward-line)) + (/= (following-char) ?\[))))))) + ;; Accumulate results into res + (dolist (f cached) + (when (not (member f removed)) (cl-pushnew f res :test #'equal))) + (dolist (f added) + (when (not (member f removed)) (push f res))) + (dolist (f removed) + (setq res (delete f res))) + (dolist (f defaults) + (push f res)) + (setq defaults nil added nil removed nil cached nil)))) + (delete-dups res))) + +(defun xdg-mime-apps (mime) + "Return list of desktop files associated with MIME, otherwise nil. +The list is in order of descending priority, and each element is +an absolute file name of a readable file. +Results are cached in `xdg-mime-table'." + (pcase-let ((`(,type ,subtype) (split-string mime "/")) + (xdg-data-dirs (xdg-data-dirs)) + (caches (xdg-mime-apps-files)) + (files ())) + (let ((mtim1 (get 'xdg-mime-table 'mtime)) + (mtim2 (cl-loop for f in caches when (file-readable-p f) + maximize (float-time (nth 5 (file-attributes f)))))) + ;; If one of the MIME/Desktop cache files has been modified: + (when (or (null mtim1) (time-less-p mtim1 mtim2)) + (setq xdg-mime-table nil))) + (when (null (assoc type xdg-mime-table)) + (push (cons type (make-hash-table :test #'equal)) xdg-mime-table)) + (if (let ((def (make-symbol "def")) + (table (cdr (assoc type xdg-mime-table)))) + (not (eq (setq files (gethash subtype table def)) def))) + files + (and files (setq files nil)) + (let ((dirs (mapcar (lambda (dir) (expand-file-name "applications" dir)) + (cons (xdg-data-home) xdg-data-dirs)))) + ;; Not being particular about desktop IDs + (dolist (f (nreverse (xdg-mime-collect-associations mime caches))) + (push (locate-file f dirs) files)) + (when files + (put 'xdg-mime-table 'mtime (current-time))) + (puthash subtype (delq nil files) (cdr (assoc type xdg-mime-table))))))) + (provide 'xdg) ;;; xdg.el ends here diff --git a/m4/fsusage.m4 b/m4/fsusage.m4 new file mode 100644 index 00000000000..f9dfbcb7a04 --- /dev/null +++ b/m4/fsusage.m4 @@ -0,0 +1,336 @@ +# serial 32 +# Obtaining file system usage information. + +# Copyright (C) 1997-1998, 2000-2001, 2003-2018 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. + +# Written by Jim Meyering. + +AC_DEFUN([gl_FSUSAGE], +[ + AC_CHECK_HEADERS_ONCE([sys/param.h]) + AC_CHECK_HEADERS_ONCE([sys/vfs.h sys/fs_types.h]) + AC_CHECK_HEADERS([sys/mount.h], [], [], + [AC_INCLUDES_DEFAULT + [#if HAVE_SYS_PARAM_H + #include <sys/param.h> + #endif]]) + gl_FILE_SYSTEM_USAGE([gl_cv_fs_space=yes], [gl_cv_fs_space=no]) +]) + +# Try to determine how a program can obtain file system usage information. +# If successful, define the appropriate symbol (see fsusage.c) and +# execute ACTION-IF-FOUND. Otherwise, execute ACTION-IF-NOT-FOUND. +# +# gl_FILE_SYSTEM_USAGE([ACTION-IF-FOUND[, ACTION-IF-NOT-FOUND]]) + +AC_DEFUN([gl_FILE_SYSTEM_USAGE], +[ +dnl Enable large-file support. This has the effect of changing the size +dnl of field f_blocks in 'struct statvfs' from 32 bit to 64 bit on +dnl glibc/Hurd, HP-UX 11, Solaris (32-bit mode). It also changes the size +dnl of field f_blocks in 'struct statfs' from 32 bit to 64 bit on +dnl Mac OS X >= 10.5 (32-bit mode). +AC_REQUIRE([AC_SYS_LARGEFILE]) + +AC_MSG_CHECKING([how to get file system space usage]) +ac_fsusage_space=no + +# Perform only the link test since it seems there are no variants of the +# statvfs function. This check is more than just AC_CHECK_FUNCS([statvfs]) +# because that got a false positive on SCO OSR5. Adding the declaration +# of a 'struct statvfs' causes this test to fail (as it should) on such +# systems. That system is reported to work fine with STAT_STATFS4 which +# is what it gets when this test fails. +if test $ac_fsusage_space = no; then + # glibc/{Hurd,kFreeBSD}, FreeBSD >= 5.0, NetBSD >= 3.0, + # OpenBSD >= 4.4, AIX, HP-UX, IRIX, Solaris, Cygwin, Interix, BeOS. + AC_CACHE_CHECK([for statvfs function (SVR4)], [fu_cv_sys_stat_statvfs], + [AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include <sys/types.h> +#ifdef __osf__ +"Do not use Tru64's statvfs implementation" +#endif + +#include <sys/statvfs.h> + +struct statvfs fsd; + +#if defined __APPLE__ && defined __MACH__ +#include <limits.h> +/* On Mac OS X >= 10.5, f_blocks in 'struct statvfs' is a 32-bit quantity; + that commonly limits file systems to 4 TiB. Whereas f_blocks in + 'struct statfs' is a 64-bit type, thanks to the large-file support + that was enabled above. In this case, don't use statvfs(); use statfs() + instead. */ +int check_f_blocks_size[sizeof fsd.f_blocks * CHAR_BIT <= 32 ? -1 : 1]; +#endif +]], + [[statvfs (0, &fsd);]])], + [fu_cv_sys_stat_statvfs=yes], + [fu_cv_sys_stat_statvfs=no])]) + if test $fu_cv_sys_stat_statvfs = yes; then + ac_fsusage_space=yes + # AIX >= 5.2 has statvfs64 that has a wider f_blocks field than statvfs. + # glibc, HP-UX, IRIX, Solaris have statvfs64 as well, but on these systems + # statvfs with large-file support is already equivalent to statvfs64. + AC_CACHE_CHECK([whether to use statvfs64], + [fu_cv_sys_stat_statvfs64], + [AC_LINK_IFELSE( + [AC_LANG_PROGRAM( + [[#include <sys/types.h> + #include <sys/statvfs.h> + struct statvfs64 fsd; + int check_f_blocks_larger_in_statvfs64 + [sizeof (((struct statvfs64 *) 0)->f_blocks) + > sizeof (((struct statvfs *) 0)->f_blocks) + ? 1 : -1]; + ]], + [[statvfs64 (0, &fsd);]])], + [fu_cv_sys_stat_statvfs64=yes], + [fu_cv_sys_stat_statvfs64=no]) + ]) + if test $fu_cv_sys_stat_statvfs64 = yes; then + AC_DEFINE([STAT_STATVFS64], [1], + [ Define if statvfs64 should be preferred over statvfs.]) + else + AC_DEFINE([STAT_STATVFS], [1], + [ Define if there is a function named statvfs. (SVR4)]) + fi + fi +fi + +# Check for this unconditionally so we have a +# good fallback on glibc/Linux > 2.6 < 2.6.36 +AC_MSG_CHECKING([for two-argument statfs with statfs.f_frsize member]) +AC_CACHE_VAL([fu_cv_sys_stat_statfs2_frsize], +[AC_RUN_IFELSE([AC_LANG_SOURCE([[ +#ifdef HAVE_SYS_PARAM_H +#include <sys/param.h> +#endif +#ifdef HAVE_SYS_MOUNT_H +#include <sys/mount.h> +#endif +#ifdef HAVE_SYS_VFS_H +#include <sys/vfs.h> +#endif + int + main () + { + struct statfs fsd; + fsd.f_frsize = 0; + return statfs (".", &fsd) != 0; + }]])], + [fu_cv_sys_stat_statfs2_frsize=yes], + [fu_cv_sys_stat_statfs2_frsize=no], + [fu_cv_sys_stat_statfs2_frsize=no])]) +AC_MSG_RESULT([$fu_cv_sys_stat_statfs2_frsize]) +if test $fu_cv_sys_stat_statfs2_frsize = yes; then + ac_fsusage_space=yes + AC_DEFINE([STAT_STATFS2_FRSIZE], [1], +[ Define if statfs takes 2 args and struct statfs has a field named f_frsize. + (glibc/Linux > 2.6)]) +fi + +if test $ac_fsusage_space = no; then + # DEC Alpha running OSF/1 + AC_MSG_CHECKING([for 3-argument statfs function (DEC OSF/1)]) + AC_CACHE_VAL([fu_cv_sys_stat_statfs3_osf1], + [AC_RUN_IFELSE([AC_LANG_SOURCE([[ +#include <sys/param.h> +#include <sys/types.h> +#include <sys/mount.h> + int + main () + { + struct statfs fsd; + fsd.f_fsize = 0; + return statfs (".", &fsd, sizeof (struct statfs)) != 0; + }]])], + [fu_cv_sys_stat_statfs3_osf1=yes], + [fu_cv_sys_stat_statfs3_osf1=no], + [fu_cv_sys_stat_statfs3_osf1=no])]) + AC_MSG_RESULT([$fu_cv_sys_stat_statfs3_osf1]) + if test $fu_cv_sys_stat_statfs3_osf1 = yes; then + ac_fsusage_space=yes + AC_DEFINE([STAT_STATFS3_OSF1], [1], + [ Define if statfs takes 3 args. (DEC Alpha running OSF/1)]) + fi +fi + +if test $ac_fsusage_space = no; then + # glibc/Linux, Mac OS X, FreeBSD < 5.0, NetBSD < 3.0, OpenBSD < 4.4. + # (glibc/{Hurd,kFreeBSD}, FreeBSD >= 5.0, NetBSD >= 3.0, + # OpenBSD >= 4.4, AIX, HP-UX, OSF/1, Cygwin already handled above.) + # (On IRIX you need to include <sys/statfs.h>, not only <sys/mount.h> and + # <sys/vfs.h>.) + # (On Solaris, statfs has 4 arguments.) + AC_MSG_CHECKING([for two-argument statfs with statfs.f_bsize dnl +member (AIX, 4.3BSD)]) + AC_CACHE_VAL([fu_cv_sys_stat_statfs2_bsize], + [AC_RUN_IFELSE([AC_LANG_SOURCE([[ +#ifdef HAVE_SYS_PARAM_H +#include <sys/param.h> +#endif +#ifdef HAVE_SYS_MOUNT_H +#include <sys/mount.h> +#endif +#ifdef HAVE_SYS_VFS_H +#include <sys/vfs.h> +#endif + int + main () + { + struct statfs fsd; + fsd.f_bsize = 0; + return statfs (".", &fsd) != 0; + }]])], + [fu_cv_sys_stat_statfs2_bsize=yes], + [fu_cv_sys_stat_statfs2_bsize=no], + [fu_cv_sys_stat_statfs2_bsize=no])]) + AC_MSG_RESULT([$fu_cv_sys_stat_statfs2_bsize]) + if test $fu_cv_sys_stat_statfs2_bsize = yes; then + ac_fsusage_space=yes + AC_DEFINE([STAT_STATFS2_BSIZE], [1], +[ Define if statfs takes 2 args and struct statfs has a field named f_bsize. + (4.3BSD, SunOS 4, HP-UX, AIX PS/2)]) + fi +fi + +if test $ac_fsusage_space = no; then + # SVR3 + # (Solaris already handled above.) + AC_MSG_CHECKING([for four-argument statfs (AIX-3.2.5, SVR3)]) + AC_CACHE_VAL([fu_cv_sys_stat_statfs4], + [AC_RUN_IFELSE([AC_LANG_SOURCE([[ +#include <sys/types.h> +#include <sys/statfs.h> + int + main () + { + struct statfs fsd; + return statfs (".", &fsd, sizeof fsd, 0) != 0; + }]])], + [fu_cv_sys_stat_statfs4=yes], + [fu_cv_sys_stat_statfs4=no], + [fu_cv_sys_stat_statfs4=no])]) + AC_MSG_RESULT([$fu_cv_sys_stat_statfs4]) + if test $fu_cv_sys_stat_statfs4 = yes; then + ac_fsusage_space=yes + AC_DEFINE([STAT_STATFS4], [1], + [ Define if statfs takes 4 args. (SVR3, Dynix, old Irix, old AIX, Dolphin)]) + fi +fi + +if test $ac_fsusage_space = no; then + # 4.4BSD and older NetBSD + # (OSF/1 already handled above.) + # (On AIX, you need to include <sys/statfs.h>, not only <sys/mount.h>.) + # (On Solaris, statfs has 4 arguments and 'struct statfs' is not declared in + # <sys/mount.h>.) + AC_MSG_CHECKING([for two-argument statfs with statfs.f_fsize dnl +member (4.4BSD and NetBSD)]) + AC_CACHE_VAL([fu_cv_sys_stat_statfs2_fsize], + [AC_RUN_IFELSE([AC_LANG_SOURCE([[ +#include <sys/types.h> +#ifdef HAVE_SYS_PARAM_H +#include <sys/param.h> +#endif +#ifdef HAVE_SYS_MOUNT_H +#include <sys/mount.h> +#endif + int + main () + { + struct statfs fsd; + fsd.f_fsize = 0; + return statfs (".", &fsd) != 0; + }]])], + [fu_cv_sys_stat_statfs2_fsize=yes], + [fu_cv_sys_stat_statfs2_fsize=no], + [fu_cv_sys_stat_statfs2_fsize=no])]) + AC_MSG_RESULT([$fu_cv_sys_stat_statfs2_fsize]) + if test $fu_cv_sys_stat_statfs2_fsize = yes; then + ac_fsusage_space=yes + AC_DEFINE([STAT_STATFS2_FSIZE], [1], +[ Define if statfs takes 2 args and struct statfs has a field named f_fsize. + (4.4BSD, NetBSD)]) + fi +fi + +if test $ac_fsusage_space = no; then + # Ultrix + AC_MSG_CHECKING([for two-argument statfs with struct fs_data (Ultrix)]) + AC_CACHE_VAL([fu_cv_sys_stat_fs_data], + [AC_RUN_IFELSE([AC_LANG_SOURCE([[ +#include <sys/types.h> +#ifdef HAVE_SYS_PARAM_H +#include <sys/param.h> +#endif +#ifdef HAVE_SYS_MOUNT_H +#include <sys/mount.h> +#endif +#ifdef HAVE_SYS_FS_TYPES_H +#include <sys/fs_types.h> +#endif + int + main () + { + struct fs_data fsd; + /* Ultrix's statfs returns 1 for success, + 0 for not mounted, -1 for failure. */ + return statfs (".", &fsd) != 1; + }]])], + [fu_cv_sys_stat_fs_data=yes], + [fu_cv_sys_stat_fs_data=no], + [fu_cv_sys_stat_fs_data=no])]) + AC_MSG_RESULT([$fu_cv_sys_stat_fs_data]) + if test $fu_cv_sys_stat_fs_data = yes; then + ac_fsusage_space=yes + AC_DEFINE([STAT_STATFS2_FS_DATA], [1], +[ Define if statfs takes 2 args and the second argument has + type struct fs_data. (Ultrix)]) + fi +fi + +AS_IF([test $ac_fsusage_space = yes], [$1], [$2]) + +]) + + +# Check for SunOS statfs brokenness wrt partitions 2GB and larger. +# If <sys/vfs.h> exists and struct statfs has a member named f_spare, +# enable the work-around code in fsusage.c. +AC_DEFUN([gl_STATFS_TRUNCATES], +[ + AC_MSG_CHECKING([for statfs that truncates block counts]) + AC_CACHE_VAL([fu_cv_sys_truncating_statfs], + [AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[ +#if !defined(sun) && !defined(__sun) +choke -- this is a workaround for a Sun-specific problem +#endif +#include <sys/types.h> +#include <sys/vfs.h>]], + [[struct statfs t; long c = *(t.f_spare); + if (c) return 0;]])], + [fu_cv_sys_truncating_statfs=yes], + [fu_cv_sys_truncating_statfs=no])]) + if test $fu_cv_sys_truncating_statfs = yes; then + AC_DEFINE([STATFS_TRUNCATES_BLOCK_COUNTS], [1], + [Define if the block counts reported by statfs may be truncated to 2GB + and the correct values may be stored in the f_spare array. + (SunOS 4.1.2, 4.1.3, and 4.1.3_U1 are reported to have this problem. + SunOS 4.1.1 seems not to be affected.)]) + fi + AC_MSG_RESULT([$fu_cv_sys_truncating_statfs]) +]) + + +# Prerequisites of lib/fsusage.c not done by gl_FILE_SYSTEM_USAGE. +AC_DEFUN([gl_PREREQ_FSUSAGE_EXTRA], +[ + AC_CHECK_HEADERS([dustat.h sys/fs/s5param.h sys/statfs.h]) + gl_STATFS_TRUNCATES +]) diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index 167356faed4..fc03db2aa86 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -87,6 +87,7 @@ AC_DEFUN([gl_EARLY], # Code from module flexmember: # Code from module fpending: # Code from module fstatat: + # Code from module fsusage: # Code from module fsync: # Code from module getdtablesize: # Code from module getgroups: @@ -256,6 +257,11 @@ AC_DEFUN([gl_INIT], AC_LIBOBJ([fstatat]) fi gl_SYS_STAT_MODULE_INDICATOR([fstatat]) + gl_FSUSAGE + if test $gl_cv_fs_space = yes; then + AC_LIBOBJ([fsusage]) + gl_PREREQ_FSUSAGE_EXTRA + fi gl_FUNC_FSYNC if test $HAVE_FSYNC = 0; then AC_LIBOBJ([fsync]) @@ -864,6 +870,8 @@ AC_DEFUN([gl_FILE_LIST], [ lib/fpending.c lib/fpending.h lib/fstatat.c + lib/fsusage.c + lib/fsusage.h lib/fsync.c lib/ftoastr.c lib/ftoastr.h @@ -995,6 +1003,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/flexmember.m4 m4/fpending.m4 m4/fstatat.m4 + m4/fsusage.m4 m4/fsync.m4 m4/getdtablesize.m4 m4/getgroups.m4 diff --git a/msdos/sed2v2.inp b/msdos/sed2v2.inp index d6e13556ff7..c57fa4b0416 100644 --- a/msdos/sed2v2.inp +++ b/msdos/sed2v2.inp @@ -65,7 +65,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 "26.0.90"/ +/^#undef PACKAGE_VERSION/s/^.*$/#define PACKAGE_VERSION "27.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/INSTALL b/nt/INSTALL index 6d0ecdbfbd9..d2e5e99c0c9 100644 --- a/nt/INSTALL +++ b/nt/INSTALL @@ -806,6 +806,13 @@ build will run on Windows 9X and newer systems). Prebuilt binaries of lcms2 DLL (for 32-bit builds of Emacs) are available from the ezwinports site and from the MSYS2 project. +* Optional support for JSON + + Emacs can provide built-in support for JSON parsing and + serialization using the libjansson library. Prebuilt binaries of + the libjansson DLL (for 32-bit builds of Emacs) are available from + the ezwinports site and from the MSYS2 project. + This file is part of GNU Emacs. diff --git a/nt/INSTALL.W64 b/nt/INSTALL.W64 index 6c697151221..c3aa85e8c92 100644 --- a/nt/INSTALL.W64 +++ b/nt/INSTALL.W64 @@ -52,6 +52,7 @@ packages (you can copy and paste it into the shell with Shift + Insert): mingw-w64-x86_64-libjpeg-turbo \ mingw-w64-x86_64-librsvg \ mingw-w64-x86_64-lcms2 \ + mingw-w64-x86_64-jansson \ mingw-w64-x86_64-libxml2 \ mingw-w64-x86_64-gnutls \ mingw-w64-x86_64-zlib diff --git a/nt/README.W32 b/nt/README.W32 index 8ff07209e61..f0147b4c68f 100644 --- a/nt/README.W32 +++ b/nt/README.W32 @@ -1,7 +1,7 @@ Copyright (C) 2001-2018 Free Software Foundation, Inc. See the end of the file for license conditions. - Emacs version 26.0.90 for MS-Windows + Emacs version 27.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 340c407866d..21d42337e84 100644 --- a/nt/gnulib-cfg.mk +++ b/nt/gnulib-cfg.mk @@ -49,6 +49,7 @@ OMIT_GNULIB_MODULE_dirent = true OMIT_GNULIB_MODULE_dirfd = true OMIT_GNULIB_MODULE_fcntl = true OMIT_GNULIB_MODULE_fcntl-h = true +OMIT_GNULIB_MODULE_fsusage = true OMIT_GNULIB_MODULE_inttypes-incomplete = true OMIT_GNULIB_MODULE_open = true OMIT_GNULIB_MODULE_pipe2 = true diff --git a/src/.gdbinit b/src/.gdbinit index db7185bc450..a5411e66d56 100644 --- a/src/.gdbinit +++ b/src/.gdbinit @@ -49,7 +49,7 @@ define xgetptr else set $bugfix = $arg0 end - set $ptr = $bugfix & VALMASK + set $ptr = (EMACS_INT) $bugfix & VALMASK end define xgetint @@ -58,7 +58,7 @@ define xgetint else set $bugfix = $arg0 end - set $int = $bugfix << (USE_LSB_TAG ? 0 : INTTYPEBITS) >> INTTYPEBITS + set $int = (EMACS_INT) $bugfix << (USE_LSB_TAG ? 0 : INTTYPEBITS) >> INTTYPEBITS end define xgettype @@ -67,7 +67,7 @@ define xgettype else set $bugfix = $arg0 end - set $type = (enum Lisp_Type) (USE_LSB_TAG ? $bugfix & (1 << GCTYPEBITS) - 1 : (EMACS_UINT) $bugfix >> VALBITS) + set $type = (enum Lisp_Type) (USE_LSB_TAG ? (EMACS_INT) $bugfix & (1 << GCTYPEBITS) - 1 : (EMACS_UINT) $bugfix >> VALBITS) end define xgetsym @@ -1321,19 +1321,26 @@ if hasattr(gdb, 'printing'): Lisp_Int0 = 2 Lisp_Int1 = 6 if USE_LSB_TAG else 3 - # Unpack the Lisp value from its containing structure, if necessary. val = self.val basic_type = gdb.types.get_basic_type (val.type) + + # Unpack VAL from its containing structure, if necessary. if (basic_type.code == gdb.TYPE_CODE_STRUCT and gdb.types.has_field (basic_type, "i")): val = val["i"] + # Convert VAL to a Python integer. Convert by hand, as this is + # simpler and works regardless of whether VAL is a pointer or + # integer. Also, val.cast (gdb.lookup.type ("EMACS_UINT")) + # would have problems with GDB 7.12.1; see + # <http://patchwork.sourceware.org/patch/11557/>. + ival = int (val) + # For nil, yield "XIL(0)", which is easier to read than "XIL(0x0)". - if not val: + if not ival: return "XIL(0)" # Extract the integer representation of the value and its Lisp type. - ival = int(val) itype = ival >> (0 if USE_LSB_TAG else VALBITS) itype = itype & ((1 << GCTYPEBITS) - 1) @@ -1352,8 +1359,7 @@ if hasattr(gdb, 'printing'): # integers even when Lisp_Object is an integer. # Perhaps some day the pretty-printing could be fancier. # Prefer the unsigned representation to negative values, converting - # by hand as val.cast(gdb.lookup_type("EMACS_UINT") does not work in - # GDB 7.12.1; see <http://patchwork.sourceware.org/patch/11557/>. + # by hand as val.cast does not work in GDB 7.12.1 as noted above. if ival < 0: ival = ival + (1 << EMACS_INT_WIDTH) return "XIL(0x%x)" % ival diff --git a/src/Makefile.in b/src/Makefile.in index e622ade931e..837bed1acd6 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -312,6 +312,10 @@ LIBGNUTLS_CFLAGS = @LIBGNUTLS_CFLAGS@ LIBSYSTEMD_LIBS = @LIBSYSTEMD_LIBS@ LIBSYSTEMD_CFLAGS = @LIBSYSTEMD_CFLAGS@ +JSON_LIBS = @JSON_LIBS@ +JSON_CFLAGS = @JSON_CFLAGS@ +JSON_OBJ = @JSON_OBJ@ + INTERVALS_H = dispextern.h intervals.h composite.h GETLOADAVG_LIBS = @GETLOADAVG_LIBS@ @@ -363,7 +367,7 @@ EMACS_CFLAGS=-Demacs $(MYCPPFLAGS) -I. -I$(srcdir) \ $(WEBKIT_CFLAGS) \ $(SETTINGS_CFLAGS) $(FREETYPE_CFLAGS) $(FONTCONFIG_CFLAGS) \ $(LIBOTF_CFLAGS) $(M17N_FLT_CFLAGS) $(DEPFLAGS) \ - $(LIBSYSTEMD_CFLAGS) \ + $(LIBSYSTEMD_CFLAGS) $(JSON_CFLAGS) \ $(LIBGNUTLS_CFLAGS) $(NOTIFY_CFLAGS) $(CAIRO_CFLAGS) \ $(WERROR_CFLAGS) ALL_CFLAGS = $(EMACS_CFLAGS) $(WARN_CFLAGS) $(CFLAGS) @@ -397,7 +401,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \ thread.o systhread.o \ $(if $(HYBRID_MALLOC),sheap.o) \ $(MSDOS_OBJ) $(MSDOS_X_OBJ) $(NS_OBJ) $(CYGWIN_OBJ) $(FONT_OBJ) \ - $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) + $(W32_OBJ) $(WINDOW_SYSTEM_OBJ) $(XGSELOBJ) $(JSON_OBJ) obj = $(base_obj) $(NS_OBJC_OBJ) ## Object files used on some machine or other. @@ -493,7 +497,8 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \ $(LIBS_TERMCAP) $(GETLOADAVG_LIBS) $(SETTINGS_LIBS) $(LIBSELINUX_LIBS) \ $(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \ $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LIBLCMS2) \ - $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) + $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) \ + $(JSON_LIBS) ## FORCE it so that admin/unidata can decide whether these files ## are up-to-date. Although since charprop depends on bootstrap-emacs, diff --git a/src/alloc.c b/src/alloc.c index 6704c51a207..f7e13464892 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -33,6 +33,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "lisp.h" #include "dispextern.h" #include "intervals.h" +#include "ptr-bounds.h" #include "puresize.h" #include "sheap.h" #include "systime.h" @@ -502,38 +503,27 @@ pointer_align (void *ptr, int alignment) return (void *) ROUNDUP ((uintptr_t) ptr, alignment); } -/* Extract the pointer hidden within A, if A is not a symbol. - If A is a symbol, extract the hidden pointer's offset from lispsym, - converted to void *. */ +/* Extract the pointer hidden within O. Define this as a function, as + functions are cleaner and can be used in debuggers. Also, define + it as a macro if being compiled with GCC without optimization, for + performance in that case. macro_XPNTR is private to this section + of code. */ -#define macro_XPNTR_OR_SYMBOL_OFFSET(a) \ - ((void *) (intptr_t) (USE_LSB_TAG ? XLI (a) - XTYPE (a) : XLI (a) & VALMASK)) - -/* Extract the pointer hidden within A. */ - -#define macro_XPNTR(a) \ - ((void *) ((intptr_t) XPNTR_OR_SYMBOL_OFFSET (a) \ - + (SYMBOLP (a) ? (char *) lispsym : NULL))) - -/* For pointer access, define XPNTR and XPNTR_OR_SYMBOL_OFFSET as - functions, as functions are cleaner and can be used in debuggers. - Also, define them as macros if being compiled with GCC without - optimization, for performance in that case. The macro_* names are - private to this section of code. */ +#define macro_XPNTR(o) \ + ((void *) \ + (SYMBOLP (o) \ + ? ((char *) lispsym \ + - ((EMACS_UINT) Lisp_Symbol << (USE_LSB_TAG ? 0 : VALBITS)) \ + + XLI (o)) \ + : (char *) XLP (o) - (XLI (o) & ~VALMASK))) static ATTRIBUTE_UNUSED void * -XPNTR_OR_SYMBOL_OFFSET (Lisp_Object a) -{ - return macro_XPNTR_OR_SYMBOL_OFFSET (a); -} -static ATTRIBUTE_UNUSED void * XPNTR (Lisp_Object a) { return macro_XPNTR (a); } #if DEFINE_KEY_OPS_AS_MACROS -# define XPNTR_OR_SYMBOL_OFFSET(a) macro_XPNTR_OR_SYMBOL_OFFSET (a) # define XPNTR(a) macro_XPNTR (a) #endif @@ -1737,7 +1727,8 @@ static EMACS_INT total_string_bytes; a pointer to the `u.data' member of its sdata structure; the structure starts at a constant offset in front of that. */ -#define SDATA_OF_STRING(S) ((sdata *) ((S)->u.s.data - SDATA_DATA_OFFSET)) +#define SDATA_OF_STRING(S) ((sdata *) ptr_bounds_init ((S)->u.s.data \ + - SDATA_DATA_OFFSET)) #ifdef GC_CHECK_STRING_OVERRUN @@ -1929,7 +1920,7 @@ allocate_string (void) /* Every string on a free list should have NULL data pointer. */ s->u.s.data = NULL; NEXT_FREE_LISP_STRING (s) = string_free_list; - string_free_list = s; + string_free_list = ptr_bounds_clip (s, sizeof *s); } total_free_strings += STRING_BLOCK_SIZE; @@ -2044,7 +2035,7 @@ allocate_string_data (struct Lisp_String *s, MALLOC_UNBLOCK_INPUT; - s->u.s.data = SDATA_DATA (data); + s->u.s.data = ptr_bounds_clip (SDATA_DATA (data), nbytes + 1); #ifdef GC_CHECK_STRING_BYTES SDATA_NBYTES (data) = nbytes; #endif @@ -2130,7 +2121,7 @@ sweep_strings (void) /* Put the string on the free-list. */ NEXT_FREE_LISP_STRING (s) = string_free_list; - string_free_list = s; + string_free_list = ptr_bounds_clip (s, sizeof *s); ++nfree; } } @@ -2138,7 +2129,7 @@ sweep_strings (void) { /* S was on the free-list before. Put it there again. */ NEXT_FREE_LISP_STRING (s) = string_free_list; - string_free_list = s; + string_free_list = ptr_bounds_clip (s, sizeof *s); ++nfree; } } @@ -2234,9 +2225,9 @@ compact_small_strings (void) nbytes = s ? STRING_BYTES (s) : SDATA_NBYTES (from); eassert (nbytes <= LARGE_STRING_BYTES); - nbytes = SDATA_SIZE (nbytes); + ptrdiff_t size = SDATA_SIZE (nbytes); sdata *from_end = (sdata *) ((char *) from - + nbytes + GC_STRING_EXTRA); + + size + GC_STRING_EXTRA); #ifdef GC_CHECK_STRING_OVERRUN if (memcmp (string_overrun_cookie, @@ -2250,22 +2241,23 @@ compact_small_strings (void) { /* If TB is full, proceed with the next sblock. */ sdata *to_end = (sdata *) ((char *) to - + nbytes + GC_STRING_EXTRA); + + size + GC_STRING_EXTRA); if (to_end > tb_end) { tb->next_free = to; tb = tb->next; tb_end = (sdata *) ((char *) tb + SBLOCK_SIZE); to = tb->data; - to_end = (sdata *) ((char *) to + nbytes + GC_STRING_EXTRA); + to_end = (sdata *) ((char *) to + size + GC_STRING_EXTRA); } /* Copy, and update the string's `data' pointer. */ if (from != to) { eassert (tb != b || to < from); - memmove (to, from, nbytes + GC_STRING_EXTRA); - to->string->u.s.data = SDATA_DATA (to); + memmove (to, from, size + GC_STRING_EXTRA); + to->string->u.s.data + = ptr_bounds_clip (SDATA_DATA (to), nbytes + 1); } /* Advance past the sdata we copied to. */ @@ -2299,11 +2291,13 @@ string_overflow (void) error ("Maximum string size exceeded"); } -DEFUN ("make-string", Fmake_string, Smake_string, 2, 2, 0, +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. -INIT must be an integer that represents a character. */) - (Lisp_Object length, Lisp_Object init) +INIT must be an integer that represents a character. +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; @@ -2313,7 +2307,7 @@ INIT must be an integer that represents a character. */) CHECK_CHARACTER (init); c = XFASTINT (init); - if (ASCII_CHAR_P (c)) + if (ASCII_CHAR_P (c) && NILP (multibyte)) { nbytes = XINT (length); val = make_uninit_string (nbytes); @@ -3046,6 +3040,7 @@ static EMACS_INT total_vector_slots, total_free_vector_slots; static void setup_on_free_list (struct Lisp_Vector *v, ptrdiff_t nbytes) { + v = ptr_bounds_clip (v, nbytes); eassume (header_size <= nbytes); ptrdiff_t nwords = (nbytes - header_size) / word_size; XSETPVECTYPESIZE (v, PVEC_FREE, 0, nwords); @@ -3315,15 +3310,14 @@ sweep_vectors (void) static struct Lisp_Vector * allocate_vectorlike (ptrdiff_t len) { - struct Lisp_Vector *p; - - MALLOC_BLOCK_INPUT; - if (len == 0) - p = XVECTOR (zero_vector); + return XVECTOR (zero_vector); else { size_t nbytes = header_size + len * word_size; + struct Lisp_Vector *p; + + MALLOC_BLOCK_INPUT; #ifdef DOUG_LEA_MALLOC if (!mmap_lisp_allowed_p ()) @@ -3353,11 +3347,11 @@ allocate_vectorlike (ptrdiff_t len) consing_since_gc += nbytes; vector_cells_consed += len; - } - MALLOC_UNBLOCK_INPUT; + MALLOC_UNBLOCK_INPUT; - return p; + return ptr_bounds_clip (p, nbytes); + } } @@ -3918,7 +3912,7 @@ make_event_array (ptrdiff_t nargs, Lisp_Object *args) { Lisp_Object result; - result = Fmake_string (make_number (nargs), make_number (0)); + result = Fmake_string (make_number (nargs), make_number (0), Qnil); for (i = 0; i < nargs; i++) { SSET (result, i, XINT (args[i])); @@ -4574,6 +4568,7 @@ live_string_holding (struct mem_node *m, void *p) 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); @@ -4608,6 +4603,7 @@ live_cons_holding (struct mem_node *m, void *p) && (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 (!EQ (s->u.s.car, Vdead)) return make_lisp_ptr (s, Lisp_Cons); @@ -4643,6 +4639,7 @@ live_symbol_holding (struct mem_node *m, void *p) && (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 (!EQ (s->u.s.function, Vdead)) return make_lisp_symbol (s); @@ -4702,6 +4699,7 @@ live_misc_holding (struct mem_node *m, void *p) && (b != marker_block || offset / sizeof b->markers[0] < marker_block_index)) { + cp = ptr_bounds_copy (cp, b); union Lisp_Misc *s = p = cp -= offset % sizeof b->markers[0]; if (s->u_any.type != Lisp_Misc_Free) return make_lisp_ptr (s, Lisp_Misc); @@ -5363,7 +5361,7 @@ pure_alloc (size_t size, int type) pure_bytes_used = pure_bytes_used_lisp + pure_bytes_used_non_lisp; if (pure_bytes_used <= pure_size) - return result; + return ptr_bounds_clip (result, size); /* Don't allocate a large amount here, because it might get mmap'd and then its address @@ -5448,7 +5446,7 @@ find_string_data_in_pure (const char *data, ptrdiff_t nbytes) /* Check the remaining characters. */ if (memcmp (data, non_lisp_beg + start, nbytes) == 0) /* Found. */ - return non_lisp_beg + start; + return ptr_bounds_clip (non_lisp_beg + start, nbytes + 1); start += last_char_skip; } @@ -5604,7 +5602,7 @@ static Lisp_Object purecopy (Lisp_Object obj) { if (INTEGERP (obj) - || (! SYMBOLP (obj) && PURE_P (XPNTR_OR_SYMBOL_OFFSET (obj))) + || (! SYMBOLP (obj) && PURE_P (XPNTR (obj))) || SUBRP (obj)) return obj; /* Already pure. */ @@ -5965,6 +5963,7 @@ garbage_collect_1 (void *end) stack_copy = xrealloc (stack_copy, stack_size); stack_copy_size = stack_size; } + stack = ptr_bounds_set (stack, stack_size); no_sanitize_memcpy (stack_copy, stack, stack_size); } } @@ -6858,7 +6857,9 @@ sweep_conses (void) for (pos = start; pos < stop; pos++) { - if (!CONS_MARKED_P (&cblk->conses[pos])) + struct Lisp_Cons *acons + = ptr_bounds_copy (&cblk->conses[pos], cblk); + if (!CONS_MARKED_P (acons)) { this_free++; cblk->conses[pos].u.s.u.chain = cons_free_list; @@ -6868,7 +6869,7 @@ sweep_conses (void) else { num_used++; - CONS_UNMARK (&cblk->conses[pos]); + CONS_UNMARK (acons); } } } @@ -6911,17 +6912,20 @@ sweep_floats (void) register int i; int this_free = 0; for (i = 0; i < lim; i++) - if (!FLOAT_MARKED_P (&fblk->floats[i])) - { - this_free++; - fblk->floats[i].u.chain = float_free_list; - float_free_list = &fblk->floats[i]; - } - else - { - num_used++; - FLOAT_UNMARK (&fblk->floats[i]); - } + { + struct Lisp_Float *afloat = ptr_bounds_copy (&fblk->floats[i], fblk); + if (!FLOAT_MARKED_P (afloat)) + { + this_free++; + fblk->floats[i].u.chain = float_free_list; + float_free_list = &fblk->floats[i]; + } + else + { + num_used++; + FLOAT_UNMARK (afloat); + } + } lim = FLOAT_BLOCK_SIZE; /* If this block contains only free floats and we have already seen more than two blocks worth of free floats then deallocate diff --git a/src/buffer.c b/src/buffer.c index 9b54e4b7787..f8c57a74b4e 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -5144,7 +5144,9 @@ init_buffer_once (void) XSETFASTINT (BVAR (&buffer_local_flags, selective_display), idx); ++idx; XSETFASTINT (BVAR (&buffer_local_flags, selective_display_ellipses), idx); ++idx; XSETFASTINT (BVAR (&buffer_local_flags, tab_width), idx); ++idx; - XSETFASTINT (BVAR (&buffer_local_flags, truncate_lines), idx); ++idx; + XSETFASTINT (BVAR (&buffer_local_flags, truncate_lines), idx); + /* Make this one a permanent local. */ + buffer_permanent_local_flags[idx++] = 1; XSETFASTINT (BVAR (&buffer_local_flags, word_wrap), idx); ++idx; XSETFASTINT (BVAR (&buffer_local_flags, ctl_arrow), idx); ++idx; XSETFASTINT (BVAR (&buffer_local_flags, fill_column), idx); ++idx; diff --git a/src/bytecode.c b/src/bytecode.c index e51f9095b36..55b193ffb2f 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -24,6 +24,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "character.h" #include "buffer.h" #include "keyboard.h" +#include "ptr-bounds.h" #include "syntax.h" #include "window.h" @@ -363,13 +364,15 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, unsigned char quitcounter = 1; EMACS_INT stack_items = XFASTINT (maxdepth) + 1; USE_SAFE_ALLOCA; - Lisp_Object *stack_base; - SAFE_ALLOCA_LISP_EXTRA (stack_base, stack_items, bytestr_length); - Lisp_Object *stack_lim = stack_base + stack_items; + void *alloc; + SAFE_ALLOCA_LISP_EXTRA (alloc, stack_items, bytestr_length); + ptrdiff_t item_bytes = stack_items * word_size; + Lisp_Object *stack_base = ptr_bounds_clip (alloc, item_bytes); Lisp_Object *top = stack_base; - memcpy (stack_lim, SDATA (bytestr), bytestr_length); - void *void_stack_lim = stack_lim; - unsigned char const *bytestr_data = void_stack_lim; + Lisp_Object *stack_lim = stack_base + stack_items; + unsigned char *bytestr_data = alloc; + bytestr_data = ptr_bounds_clip (bytestr_data + item_bytes, bytestr_length); + memcpy (bytestr_data, SDATA (bytestr), bytestr_length); unsigned char const *pc = bytestr_data; ptrdiff_t count = SPECPDL_INDEX (); diff --git a/src/callint.c b/src/callint.c index ef228517f17..c713e08d4d4 100644 --- a/src/callint.c +++ b/src/callint.c @@ -21,6 +21,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <config.h> #include "lisp.h" +#include "ptr-bounds.h" #include "character.h" #include "buffer.h" #include "keyboard.h" @@ -494,6 +495,9 @@ invoke it. If KEYS is omitted or nil, the return value of varies = (signed char *) (visargs + nargs); memclear (args, nargs * (2 * word_size + 1)); + args = ptr_bounds_clip (args, nargs * sizeof *args); + visargs = ptr_bounds_clip (visargs, nargs * sizeof *visargs); + varies = ptr_bounds_clip (varies, nargs * sizeof *varies); if (!NILP (enable)) specbind (Qenable_recursive_minibuffers, Qt); diff --git a/src/cmds.c b/src/cmds.c index db3924e3f6a..96b712ed6d2 100644 --- a/src/cmds.c +++ b/src/cmds.c @@ -439,12 +439,13 @@ internal_self_insert (int c, EMACS_INT n) int mc = ((NILP (BVAR (current_buffer, enable_multibyte_characters)) && SINGLE_BYTE_CHAR_P (c)) ? UNIBYTE_TO_CHAR (c) : c); - Lisp_Object string = Fmake_string (make_number (n), make_number (mc)); + Lisp_Object string = Fmake_string (make_number (n), make_number (mc), + Qnil); if (spaces_to_insert) { tem = Fmake_string (make_number (spaces_to_insert), - make_number (' ')); + make_number (' '), Qnil); string = concat2 (string, tem); } diff --git a/src/coding.c b/src/coding.c index 35f85052c98..da625403441 100644 --- a/src/coding.c +++ b/src/coding.c @@ -1515,13 +1515,6 @@ encode_coding_utf_8 (struct coding_system *coding) /* See the above "GENERAL NOTES on `detect_coding_XXX ()' functions". Return true if a text is encoded in one of UTF-16 based coding systems. */ -#define UTF_16_HIGH_SURROGATE_P(val) \ - (((val) & 0xFC00) == 0xD800) - -#define UTF_16_LOW_SURROGATE_P(val) \ - (((val) & 0xFC00) == 0xDC00) - - static bool detect_coding_utf_16 (struct coding_system *coding, struct coding_detection_info *detect_info) @@ -6360,6 +6353,27 @@ check_utf_8 (struct coding_system *coding) } +/* Return whether STRING is a valid UTF-8 string. STRING must be a + unibyte string. */ + +bool +utf8_string_p (Lisp_Object string) +{ + eassert (!STRING_MULTIBYTE (string)); + struct coding_system coding; + setup_coding_system (Qutf_8_unix, &coding); + /* We initialize only the fields that check_utf_8 accesses. */ + coding.head_ascii = -1; + coding.src_pos = 0; + coding.src_pos_byte = 0; + coding.src_chars = SCHARS (string); + coding.src_bytes = SBYTES (string); + coding.src_object = string; + coding.eol_seen = EOL_SEEN_NONE; + return check_utf_8 (&coding) != -1; +} + + /* Detect how end-of-line of a text of length SRC_BYTES pointed by SOURCE is encoded. If CATEGORY is one of coding_category_utf_16_XXXX, assume that CR and LF are encoded by @@ -10236,7 +10250,7 @@ usage: (define-coding-system-internal ...) */) ASET (attrs, coding_attr_ccl_encoder, val); val = args[coding_arg_ccl_valids]; - valids = Fmake_string (make_number (256), make_number (0)); + valids = Fmake_string (make_number (256), make_number (0), Qnil); for (tail = val; CONSP (tail); tail = XCDR (tail)) { int from, to; @@ -10846,6 +10860,7 @@ syms_of_coding (void) DEFSYM (Qiso_2022, "iso-2022"); DEFSYM (Qutf_8, "utf-8"); + DEFSYM (Qutf_8_unix, "utf-8-unix"); DEFSYM (Qutf_8_emacs, "utf-8-emacs"); #if defined (WINDOWSNT) || defined (CYGWIN) diff --git a/src/coding.h b/src/coding.h index 2a87fc32e9d..d90b799d76e 100644 --- a/src/coding.h +++ b/src/coding.h @@ -662,9 +662,34 @@ struct coding_system /* Note that this encodes utf-8, not utf-8-emacs, so it's not a no-op. */ #define ENCODE_UTF_8(str) code_convert_string_norecord (str, Qutf_8, true) +/* Return true if VAL is a high surrogate. VAL must be a 16-bit code + unit. */ + +#define UTF_16_HIGH_SURROGATE_P(val) \ + (((val) & 0xFC00) == 0xD800) + +/* Return true if VAL is a low surrogate. VAL must be a 16-bit code + unit. */ + +#define UTF_16_LOW_SURROGATE_P(val) \ + (((val) & 0xFC00) == 0xDC00) + +/* Return the Unicode code point for the given UTF-16 surrogates. */ + +INLINE int +surrogates_to_codepoint (int low, int high) +{ + eassert (0 <= low && low <= 0xFFFF); + eassert (0 <= high && high <= 0xFFFF); + eassert (UTF_16_LOW_SURROGATE_P (low)); + eassert (UTF_16_HIGH_SURROGATE_P (high)); + return 0x10000 + (low - 0xDC00) + ((high - 0xD800) * 0x400); +} + /* Extern declarations. */ extern Lisp_Object code_conversion_save (bool, bool); extern bool encode_coding_utf_8 (struct coding_system *); +extern bool utf8_string_p (Lisp_Object); extern void setup_coding_system (Lisp_Object, struct coding_system *); extern Lisp_Object coding_charset_list (struct coding_system *); extern Lisp_Object coding_system_charset_list (Lisp_Object); diff --git a/src/data.c b/src/data.c index 53a92ac03bb..72abfefb01f 100644 --- a/src/data.c +++ b/src/data.c @@ -1852,7 +1852,7 @@ The function `default-value' gets the default value and `set-default' sets it. } if (SYMBOL_CONSTANT_P (variable)) - error ("Symbol %s may not be buffer-local", SDATA (SYMBOL_NAME (variable))); + xsignal1 (Qsetting_constant, variable); if (!blv) { @@ -1915,8 +1915,7 @@ Instead, use `add-hook' and specify t for the LOCAL argument. */) } if (sym->u.s.trapped_write == SYMBOL_NOWRITE) - error ("Symbol %s may not be buffer-local", - SDATA (SYMBOL_NAME (variable))); + xsignal1 (Qsetting_constant, variable); if (blv ? blv->local_if_set : (forwarded && BUFFER_OBJFWDP (valcontents.fwd))) @@ -3069,6 +3068,22 @@ usage: (logxor &rest INTS-OR-MARKERS) */) return arith_driver (Alogxor, nargs, args); } +DEFUN ("logcount", Flogcount, Slogcount, 1, 1, 0, + doc: /* Return population count of VALUE. +This is the number of one bits in the two's complement representation +of VALUE. If VALUE is negative, return the number of zero bits in the +representation. */) + (Lisp_Object value) +{ + CHECK_NUMBER (value); + EMACS_INT v = XINT (value) < 0 ? -1 - XINT (value) : XINT (value); + return make_number (EMACS_UINT_WIDTH <= UINT_WIDTH + ? count_one_bits (v) + : EMACS_UINT_WIDTH <= ULONG_WIDTH + ? count_one_bits_l (v) + : count_one_bits_ll (v)); +} + static Lisp_Object ash_lsh_impl (Lisp_Object value, Lisp_Object count, bool lsh) { @@ -3856,6 +3871,7 @@ syms_of_data (void) defsubr (&Slogand); defsubr (&Slogior); defsubr (&Slogxor); + defsubr (&Slogcount); defsubr (&Slsh); defsubr (&Sash); defsubr (&Sadd1); diff --git a/src/dispnew.c b/src/dispnew.c index ae6799bb85c..6b39c12f910 100644 --- a/src/dispnew.c +++ b/src/dispnew.c @@ -25,6 +25,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <unistd.h> #include "lisp.h" +#include "ptr-bounds.h" #include "termchar.h" /* cm.h must come after dispextern.h on Windows. */ #include "dispextern.h" @@ -4652,6 +4653,11 @@ scrolling (struct frame *frame) unsigned *new_hash = old_hash + height; int *draw_cost = (int *) (new_hash + height); int *old_draw_cost = draw_cost + height; + old_hash = ptr_bounds_clip (old_hash, height * sizeof *old_hash); + new_hash = ptr_bounds_clip (new_hash, height * sizeof *new_hash); + draw_cost = ptr_bounds_clip (draw_cost, height * sizeof *draw_cost); + old_draw_cost = ptr_bounds_clip (old_draw_cost, + height * sizeof *old_draw_cost); eassert (current_matrix); diff --git a/src/doprnt.c b/src/doprnt.c index cc5ce65105b..f194b43e0a9 100644 --- a/src/doprnt.c +++ b/src/doprnt.c @@ -503,7 +503,7 @@ esprintf (char *buf, char const *format, ...) return nbytes; } -#if HAVE_MODULES || (defined HAVE_X_WINDOWS && defined USE_X_TOOLKIT) +#if defined HAVE_X_WINDOWS && defined USE_X_TOOLKIT /* Format to buffer *BUF of positive size *BUFSIZE, reallocating *BUF and updating *BUFSIZE if the buffer is too small, and otherwise diff --git a/src/editfns.c b/src/editfns.c index c4bbbb1ba48..80871a778b9 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -56,6 +56,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "composite.h" #include "intervals.h" +#include "ptr-bounds.h" #include "character.h" #include "buffer.h" #include "coding.h" @@ -1257,10 +1258,10 @@ If POS is out of range, the value is nil. */) if (NILP (pos)) { pos_byte = PT_BYTE; - XSETFASTINT (pos, PT); + if (pos_byte < BEGV_BYTE || pos_byte >= ZV_BYTE) + return Qnil; } - - if (MARKERP (pos)) + else if (MARKERP (pos)) { pos_byte = marker_byte_position (pos); if (pos_byte < BEGV_BYTE || pos_byte >= ZV_BYTE) @@ -3718,7 +3719,7 @@ It returns the number of characters changed. */) } else { - string = Fmake_string (make_number (1), val); + string = Fmake_string (make_number (1), val, Qnil); } replace_range (pos, pos + len, string, 1, 0, 1, 0); pos_byte += SBYTES (string); @@ -4208,9 +4209,9 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) ptrdiff_t nspec_bound = SCHARS (args[0]) >> 1; /* Allocate the info and discarded tables. */ - ptrdiff_t alloca_size; - if (INT_MULTIPLY_WRAPV (nspec_bound, sizeof *info, &alloca_size) - || INT_ADD_WRAPV (formatlen, alloca_size, &alloca_size) + ptrdiff_t info_size, alloca_size; + if (INT_MULTIPLY_WRAPV (nspec_bound, sizeof *info, &info_size) + || INT_ADD_WRAPV (formatlen, info_size, &alloca_size) || SIZE_MAX < alloca_size) memory_full (SIZE_MAX); info = SAFE_ALLOCA (alloca_size); @@ -4218,6 +4219,8 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) string was not copied into the output. It is 2 if byte I was not the first byte of its character. */ char *discarded = (char *) &info[nspec_bound]; + info = ptr_bounds_clip (info, info_size); + discarded = ptr_bounds_clip (discarded, formatlen); memset (discarded, 0, formatlen); /* Try to determine whether the result should be multibyte. @@ -4623,6 +4626,7 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) /* Don't use sprintf here, as it might mishandle prec. */ sprintf_buf[0] = XINT (arg); sprintf_bytes = prec != 0; + sprintf_buf[sprintf_bytes] = '\0'; } else if (conversion == 'd' || conversion == 'i') { @@ -4722,11 +4726,19 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) char src0 = src[0]; int exponent_bytes = 0; bool signedp = src0 == '-' || src0 == '+' || src0 == ' '; - unsigned char after_sign = src[signedp]; - if (zero_flag && 0 <= char_hexdigit (after_sign)) + int prefix_bytes = (signedp + + ((src[signedp] == '0' + && (src[signedp + 1] == 'x' + || src[signedp + 1] == 'X')) + ? 2 : 0)); + if (zero_flag) { - leading_zeros += padding; - padding = 0; + unsigned char after_prefix = src[prefix_bytes]; + if (0 <= char_hexdigit (after_prefix)) + { + leading_zeros += padding; + padding = 0; + } } if (excess_precision @@ -4745,13 +4757,13 @@ styled_format (ptrdiff_t nargs, Lisp_Object *args, bool message) nchars += padding; } - *p = src0; - src += signedp; - p += signedp; + memcpy (p, src, prefix_bytes); + p += prefix_bytes; + src += prefix_bytes; memset (p, '0', leading_zeros); p += leading_zeros; int significand_bytes - = sprintf_bytes - signedp - exponent_bytes; + = sprintf_bytes - prefix_bytes - exponent_bytes; memcpy (p, src, significand_bytes); p += significand_bytes; src += significand_bytes; @@ -5281,8 +5293,7 @@ Transposing beyond buffer boundaries is an error. */) { USE_SAFE_ALLOCA; - modify_text (start1, end1); - modify_text (start2, end2); + modify_text (start1, end2); record_change (start1, len1); record_change (start2, len2); tmp_interval1 = copy_intervals (cur_intv, start1, len1); diff --git a/src/emacs-module.c b/src/emacs-module.c index 00f0e86d7da..4ee4014b4e1 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -36,6 +36,11 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <intprops.h> #include <verify.h> +/* Work around GCC bug 83162. */ +#if GNUC_PREREQ (4, 3, 0) +# pragma GCC diagnostic ignored "-Wclobbered" +#endif + /* We use different strategies for allocating the user-visible objects (struct emacs_runtime, emacs_env, emacs_value), depending on whether the user supplied the -module-assertions flag. If @@ -915,9 +920,8 @@ static Lisp_Object ltv_mark; static Lisp_Object value_to_lisp_bits (emacs_value v) { - intptr_t i = (intptr_t) v; if (plain_values || USE_LSB_TAG) - return XIL (i); + return XPL (v); /* With wide EMACS_INT and when tag bits are the most significant, reassembling integers differs from reassembling pointers in two @@ -926,6 +930,7 @@ value_to_lisp_bits (emacs_value v) integer when restoring, but zero-extend pointers because that makes TAG_PTR faster. */ + intptr_t i = (intptr_t) v; EMACS_UINT tag = i & (GCALIGNMENT - 1); EMACS_UINT untagged = i - tag; switch (tag) @@ -989,13 +994,22 @@ value_to_lisp (emacs_value v) static emacs_value lisp_to_value_bits (Lisp_Object o) { - EMACS_UINT u = XLI (o); + if (plain_values || USE_LSB_TAG) + return XLP (o); - /* Compress U into the space of a pointer, possibly losing information. */ - uintptr_t p = (plain_values || USE_LSB_TAG - ? u - : (INTEGERP (o) ? u << VALBITS : u & VALMASK) + XTYPE (o)); - return (emacs_value) p; + /* Compress O into the space of a pointer, possibly losing information. */ + EMACS_UINT u = XLI (o); + if (INTEGERP (o)) + { + uintptr_t i = (u << VALBITS) + XTYPE (o); + return (emacs_value) i; + } + else + { + char *p = XLP (o); + void *v = p - (u & ~VALMASK) + XTYPE (o); + return v; + } } /* Convert O to an emacs_value. Allocate storage if needed; this can diff --git a/src/emacs.c b/src/emacs.c index 017c62308c1..20ced262835 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -83,6 +83,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "charset.h" #include "composite.h" #include "dispextern.h" +#include "ptr-bounds.h" #include "regex.h" #include "sheap.h" #include "syntax.h" @@ -1262,6 +1263,10 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem running_asynch_code = 0; init_random (); +#if defined HAVE_JSON && !defined WINDOWSNT + init_json (); +#endif + no_loadup = argmatch (argv, argc, "-nl", "--no-loadup", 6, NULL, &skip_args); @@ -1542,9 +1547,7 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem #endif #endif /* HAVE_X_WINDOWS */ -#ifdef HAVE_LIBXML2 syms_of_xml (); -#endif #ifdef HAVE_LCMS2 syms_of_lcms2 (); @@ -1610,6 +1613,10 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem syms_of_threads (); syms_of_profiler (); +#ifdef HAVE_JSON + syms_of_json (); +#endif + keys_of_casefiddle (); keys_of_cmds (); keys_of_buffer (); diff --git a/src/eval.c b/src/eval.c index e05a17f7b4b..3c2b300096b 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1416,6 +1416,57 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *), } } +static Lisp_Object +internal_catch_all_1 (Lisp_Object (*function) (void *), void *argument) +{ + struct handler *c = push_handler_nosignal (Qt, CATCHER_ALL); + if (c == NULL) + return Qcatch_all_memory_full; + + if (sys_setjmp (c->jmp) == 0) + { + Lisp_Object val = function (argument); + eassert (handlerlist == c); + handlerlist = c->next; + return val; + } + else + { + eassert (handlerlist == c); + Lisp_Object val = c->val; + handlerlist = c->next; + Fsignal (Qno_catch, val); + } +} + +/* Like a combination of internal_condition_case_1 and internal_catch. + Catches all signals and throws. Never exits nonlocally; returns + Qcatch_all_memory_full if no handler could be allocated. */ + +Lisp_Object +internal_catch_all (Lisp_Object (*function) (void *), void *argument, + Lisp_Object (*handler) (Lisp_Object)) +{ + struct handler *c = push_handler_nosignal (Qt, CONDITION_CASE); + if (c == NULL) + return Qcatch_all_memory_full; + + if (sys_setjmp (c->jmp) == 0) + { + Lisp_Object val = internal_catch_all_1 (function, argument); + eassert (handlerlist == c); + handlerlist = c->next; + return val; + } + else + { + eassert (handlerlist == c); + Lisp_Object val = c->val; + handlerlist = c->next; + return handler (val); + } +} + struct handler * push_handler (Lisp_Object tag_ch_val, enum handlertype handlertype) { @@ -1986,12 +2037,10 @@ it defines a macro. */) if (!CONSP (fundef) || !EQ (Qautoload, XCAR (fundef))) return fundef; - if (EQ (macro_only, Qmacro)) - { - Lisp_Object kind = Fnth (make_number (4), fundef); - if (! (EQ (kind, Qt) || EQ (kind, Qmacro))) - return fundef; - } + Lisp_Object kind = Fnth (make_number (4), fundef); + if (EQ (macro_only, Qmacro) + && !(EQ (kind, Qt) || EQ (kind, Qmacro))) + return fundef; /* This is to make sure that loadup.el gives a clear picture of what files are preloaded and when. */ @@ -2014,15 +2063,18 @@ it defines a macro. */) The value saved here is to be restored into Vautoload_queue. */ record_unwind_protect (un_autoload, Vautoload_queue); Vautoload_queue = Qt; - /* If `macro_only', assume this autoload to be a "best-effort", + /* If `macro_only' is set and fundef isn't a macro, assume this autoload to + be a "best-effort" (e.g. to try and find a compiler macro), so don't signal an error if autoloading fails. */ - Fload (Fcar (Fcdr (fundef)), macro_only, Qt, Qnil, Qt); + Lisp_Object ignore_errors + = (EQ (kind, Qt) || EQ (kind, Qmacro)) ? Qnil : macro_only; + Fload (Fcar (Fcdr (fundef)), ignore_errors, Qt, Qnil, Qt); /* Once loading finishes, don't undo it. */ Vautoload_queue = Qt; unbind_to (count, Qnil); - if (NILP (funname)) + if (NILP (funname) || !NILP (ignore_errors)) return Qnil; else { @@ -4066,6 +4118,9 @@ alist of active lexical bindings. */); inhibit_lisp_code = Qnil; + DEFSYM (Qcatch_all_memory_full, "catch-all-memory-full"); + Funintern (Qcatch_all_memory_full, Qnil); + defsubr (&Sor); defsubr (&Sand); defsubr (&Sif); diff --git a/src/fileio.c b/src/fileio.c index c4a10000bc3..62f641fdea2 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -96,6 +96,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <acl.h> #include <allocator.h> #include <careadlinkat.h> +#include <fsusage.h> #include <stat-time.h> #include <tempname.h> @@ -5786,6 +5787,52 @@ effect except for flushing STREAM's data. */) return (set_binary_mode (fileno (fp), binmode) == O_BINARY) ? Qt : Qnil; } +#ifndef DOS_NT + +/* Yield a Lisp float as close as possible to BLOCKSIZE * BLOCKS, with + the result negated if NEGATE. */ +static Lisp_Object +blocks_to_bytes (uintmax_t blocksize, uintmax_t blocks, bool negate) +{ + /* On typical platforms the following code is accurate to 53 bits, + which is close enough. BLOCKSIZE is invariably a power of 2, so + converting it to double does not lose information. */ + double bs = blocksize; + return make_float (negate ? -bs * -blocks : bs * blocks); +} + +DEFUN ("file-system-info", Ffile_system_info, Sfile_system_info, 1, 1, 0, + doc: /* Return storage information about the file system FILENAME is on. +Value is a list of numbers (TOTAL FREE AVAIL), where TOTAL is the total +storage of the file system, FREE is the free storage, and AVAIL is the +storage available to a non-superuser. All 3 numbers are in bytes. +If the underlying system call fails, value is nil. */) + (Lisp_Object filename) +{ + Lisp_Object encoded = ENCODE_FILE (Fexpand_file_name (filename, Qnil)); + + /* If the file name has special constructs in it, + call the corresponding file handler. */ + Lisp_Object handler = Ffind_file_name_handler (encoded, Qfile_system_info); + if (!NILP (handler)) + { + Lisp_Object result = call2 (handler, Qfile_system_info, encoded); + if (CONSP (result) || NILP (result)) + return result; + error ("Invalid handler in `file-name-handler-alist'"); + } + + struct fs_usage u; + if (get_fs_usage (SSDATA (encoded), NULL, &u) != 0) + return Qnil; + return list3 (blocks_to_bytes (u.fsu_blocksize, u.fsu_blocks, false), + blocks_to_bytes (u.fsu_blocksize, u.fsu_bfree, false), + blocks_to_bytes (u.fsu_blocksize, u.fsu_bavail, + u.fsu_bavail_top_bit_set)); +} + +#endif /* !DOS_NT */ + void init_fileio (void) { @@ -5856,6 +5903,7 @@ syms_of_fileio (void) DEFSYM (Qwrite_region, "write-region"); DEFSYM (Qverify_visited_file_modtime, "verify-visited-file-modtime"); DEFSYM (Qset_visited_file_modtime, "set-visited-file-modtime"); + DEFSYM (Qfile_system_info, "file-system-info"); /* The symbol bound to coding-system-for-read when insert-file-contents is called for recovering a file. This is not @@ -6136,6 +6184,10 @@ This includes interactive calls to `delete-file' and defsubr (&Sset_binary_mode); +#ifndef DOS_NT + defsubr (&Sfile_system_info); +#endif + #ifdef HAVE_SYNC defsubr (&Sunix_sync); #endif diff --git a/src/fns.c b/src/fns.c index aba34fd2611..47457e44c8e 100644 --- a/src/fns.c +++ b/src/fns.c @@ -3319,6 +3319,7 @@ If the region can't be decoded, signal an error and don't modify the buffer. */ and delete the old. (Insert first in order to preserve markers.) */ TEMP_SET_PT_BOTH (XFASTINT (beg), ibeg); insert_1_both (decoded, inserted_chars, decoded_length, 0, 1, 0); + signal_after_change (XFASTINT (beg), 0, inserted_chars); SAFE_FREE (); /* Delete the original text. */ diff --git a/src/frame.c b/src/frame.c index d5b080d688a..1c6289a6b6c 100644 --- a/src/frame.c +++ b/src/frame.c @@ -35,6 +35,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "buffer.h" /* These help us bind and responding to switch-frame events. */ #include "keyboard.h" +#include "ptr-bounds.h" #include "frame.h" #include "blockinput.h" #include "termchar.h" @@ -4817,6 +4818,8 @@ xrdb_get_resource (XrmDatabase rdb, Lisp_Object attribute, Lisp_Object class, Li USE_SAFE_ALLOCA; char *name_key = SAFE_ALLOCA (name_keysize + class_keysize); char *class_key = name_key + name_keysize; + name_key = ptr_bounds_clip (name_key, name_keysize); + class_key = ptr_bounds_clip (class_key, class_keysize); /* Start with emacs.FRAMENAME for the name (the specific one) and with `Emacs' for the class key (the general one). */ @@ -4895,6 +4898,8 @@ x_get_resource_string (const char *attribute, const char *class) ptrdiff_t class_keysize = sizeof (EMACS_CLASS) - 1 + strlen (class) + 2; char *name_key = SAFE_ALLOCA (name_keysize + class_keysize); char *class_key = name_key + name_keysize; + name_key = ptr_bounds_clip (name_key, name_keysize); + class_key = ptr_bounds_clip (class_key, class_keysize); esprintf (name_key, "%s.%s", SSDATA (Vinvocation_name), attribute); sprintf (class_key, "%s.%s", EMACS_CLASS, class); diff --git a/src/fringe.c b/src/fringe.c index 34bc5db06d1..85aa14da727 100644 --- a/src/fringe.c +++ b/src/fringe.c @@ -24,6 +24,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "lisp.h" #include "frame.h" +#include "ptr-bounds.h" #include "window.h" #include "dispextern.h" #include "buffer.h" @@ -1591,7 +1592,9 @@ If BITMAP already exists, the existing definition is replaced. */) fb.dynamic = true; xfb = xmalloc (sizeof fb + fb.height * BYTES_PER_BITMAP_ROW); - fb.bits = b = (unsigned short *) (xfb + 1); + fb.bits = b = ((unsigned short *) + ptr_bounds_clip (xfb + 1, fb.height * BYTES_PER_BITMAP_ROW)); + xfb = ptr_bounds_clip (xfb, sizeof *xfb); memset (b, 0, fb.height); j = 0; diff --git a/src/gmalloc.c b/src/gmalloc.c index d013f1f72c6..ebba789f610 100644 --- a/src/gmalloc.c +++ b/src/gmalloc.c @@ -40,6 +40,8 @@ License along with this library. If not, see <https://www.gnu.org/licenses/>. # include "lisp.h" #endif +#include "ptr-bounds.h" + #ifdef HAVE_MALLOC_H # if GNUC_PREREQ (4, 2, 0) # pragma GCC diagnostic ignored "-Wdeprecated-declarations" @@ -201,7 +203,8 @@ extern size_t _bytes_free; /* Internal versions of `malloc', `realloc', and `free' used when these functions need to call each other. - They are the same but don't call the hooks. */ + They are the same but don't call the hooks + and don't bound the resulting pointers. */ extern void *_malloc_internal (size_t); extern void *_realloc_internal (void *, size_t); extern void _free_internal (void *); @@ -558,7 +561,7 @@ malloc_initialize_1 (void) _heapinfo[0].free.size = 0; _heapinfo[0].free.next = _heapinfo[0].free.prev = 0; _heapindex = 0; - _heapbase = (char *) _heapinfo; + _heapbase = (char *) ptr_bounds_init (_heapinfo); _heaplimit = BLOCK (_heapbase + heapsize * sizeof (malloc_info)); register_heapinfo (); @@ -919,7 +922,8 @@ malloc (size_t size) among multiple threads. We just leave it for compatibility with glibc malloc (i.e., assignments to gmalloc_hook) for now. */ hook = gmalloc_hook; - return (hook != NULL ? *hook : _malloc_internal) (size); + void *result = (hook ? hook : _malloc_internal) (size); + return ptr_bounds_clip (result, size); } #if !(defined (_LIBC) || defined (HYBRID_MALLOC)) @@ -997,6 +1001,7 @@ _free_internal_nolock (void *ptr) if (ptr == NULL) return; + ptr = ptr_bounds_init (ptr); PROTECT_MALLOC_STATE (0); @@ -1308,6 +1313,7 @@ _realloc_internal_nolock (void *ptr, size_t size) else if (ptr == NULL) return _malloc_internal_nolock (size); + ptr = ptr_bounds_init (ptr); block = BLOCK (ptr); PROTECT_MALLOC_STATE (0); @@ -1430,7 +1436,8 @@ realloc (void *ptr, size_t size) return NULL; hook = grealloc_hook; - return (hook != NULL ? *hook : _realloc_internal) (ptr, size); + void *result = (hook ? hook : _realloc_internal) (ptr, size); + return ptr_bounds_clip (result, size); } /* Copyright (C) 1991, 1992, 1994 Free Software Foundation, Inc. @@ -1604,6 +1611,7 @@ aligned_alloc (size_t alignment, size_t size) { l->exact = result; result = l->aligned = (char *) result + adj; + result = ptr_bounds_clip (result, size); } UNLOCK_ALIGNED_BLOCKS (); if (l == NULL) diff --git a/src/gtkutil.c b/src/gtkutil.c index 3ef0fa00a2c..047417fde84 100644 --- a/src/gtkutil.c +++ b/src/gtkutil.c @@ -1061,16 +1061,23 @@ static void xg_set_widget_bg (struct frame *f, GtkWidget *w, unsigned long pixel) { #ifdef HAVE_GTK3 - GdkRGBA bg; XColor xbg; xbg.pixel = pixel; if (XQueryColor (FRAME_X_DISPLAY (f), FRAME_X_COLORMAP (f), &xbg)) { - bg.red = (double)xbg.red/65535.0; - bg.green = (double)xbg.green/65535.0; - bg.blue = (double)xbg.blue/65535.0; - bg.alpha = 1.0; - gtk_widget_override_background_color (w, GTK_STATE_FLAG_NORMAL, &bg); + const char format[] = "* { background-color: #%02x%02x%02x; }"; + /* The format is always longer than the resulting string. */ + char buffer[sizeof format]; + int n = snprintf(buffer, sizeof buffer, format, + xbg.red >> 8, xbg.green >> 8, xbg.blue >> 8); + eassert (n > 0); + eassert (n < sizeof buffer); + GtkCssProvider *provider = gtk_css_provider_new (); + gtk_css_provider_load_from_data (provider, buffer, -1, NULL); + gtk_style_context_add_provider (gtk_widget_get_style_context(w), + GTK_STYLE_PROVIDER (provider), + GTK_STYLE_PROVIDER_PRIORITY_APPLICATION); + g_clear_object (&provider); } #else GdkColor bg; @@ -1234,9 +1241,11 @@ xg_create_frame_widgets (struct frame *f) X and GTK+ drawing to a pure GTK+ build. */ gtk_widget_set_double_buffered (wfixed, FALSE); +#if ! GTK_CHECK_VERSION (3, 22, 0) gtk_window_set_wmclass (GTK_WINDOW (wtop), SSDATA (Vx_resource_name), SSDATA (Vx_resource_class)); +#endif /* Add callback to do nothing on WM_DELETE_WINDOW. The default in GTK is to destroy the widget. We want Emacs to do that instead. */ @@ -4105,8 +4114,10 @@ xg_set_toolkit_scroll_bar_thumb (struct scroll_bar *bar, if (int_gtk_range_get_value (GTK_RANGE (wscroll)) != value) gtk_range_set_value (GTK_RANGE (wscroll), (gdouble)value); +#if ! GTK_CHECK_VERSION (3, 18, 0) else if (changed) gtk_adjustment_changed (adj); +#endif xg_ignore_gtk_scrollbar = 0; @@ -4143,7 +4154,9 @@ xg_set_toolkit_horizontal_scroll_bar_thumb (struct scroll_bar *bar, gtk_adjustment_configure (adj, (gdouble) value, (gdouble) lower, (gdouble) upper, (gdouble) step_increment, (gdouble) page_increment, (gdouble) pagesize); +#if ! GTK_CHECK_VERSION (3, 18, 0) gtk_adjustment_changed (adj); +#endif unblock_input (); } } diff --git a/src/json.c b/src/json.c new file mode 100644 index 00000000000..12ba7afa6a0 --- /dev/null +++ b/src/json.c @@ -0,0 +1,920 @@ +/* JSON parsing and serialization. + +Copyright (C) 2017-2018 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 <errno.h> +#include <stddef.h> +#include <stdint.h> +#include <stdlib.h> + +#include <jansson.h> + +#include "lisp.h" +#include "buffer.h" +#include "coding.h" + +#define JSON_HAS_ERROR_CODE (JANSSON_VERSION_HEX >= 0x020B00) + +#ifdef WINDOWSNT +# include <windows.h> +# include "w32.h" + +DEF_DLL_FN (void, json_set_alloc_funcs, + (json_malloc_t malloc_fn, json_free_t free_fn)); +DEF_DLL_FN (void, json_delete, (json_t *json)); +DEF_DLL_FN (json_t *, json_array, (void)); +DEF_DLL_FN (int, json_array_append_new, (json_t *array, json_t *value)); +DEF_DLL_FN (size_t, json_array_size, (const json_t *array)); +DEF_DLL_FN (json_t *, json_object, (void)); +DEF_DLL_FN (int, json_object_set_new, + (json_t *object, const char *key, json_t *value)); +DEF_DLL_FN (json_t *, json_null, (void)); +DEF_DLL_FN (json_t *, json_true, (void)); +DEF_DLL_FN (json_t *, json_false, (void)); +DEF_DLL_FN (json_t *, json_integer, (json_int_t value)); +DEF_DLL_FN (json_t *, json_real, (double value)); +DEF_DLL_FN (json_t *, json_stringn, (const char *value, size_t len)); +DEF_DLL_FN (char *, json_dumps, (const json_t *json, size_t flags)); +DEF_DLL_FN (int, json_dump_callback, + (const json_t *json, json_dump_callback_t callback, void *data, + size_t flags)); +DEF_DLL_FN (json_int_t, json_integer_value, (const json_t *integer)); +DEF_DLL_FN (double, json_real_value, (const json_t *real)); +DEF_DLL_FN (const char *, json_string_value, (const json_t *string)); +DEF_DLL_FN (size_t, json_string_length, (const json_t *string)); +DEF_DLL_FN (json_t *, json_array_get, (const json_t *array, size_t index)); +DEF_DLL_FN (json_t *, json_object_get, (const json_t *object, const char *key)); +DEF_DLL_FN (size_t, json_object_size, (const json_t *object)); +DEF_DLL_FN (const char *, json_object_iter_key, (void *iter)); +DEF_DLL_FN (void *, json_object_iter, (json_t *object)); +DEF_DLL_FN (json_t *, json_object_iter_value, (void *iter)); +DEF_DLL_FN (void *, json_object_key_to_iter, (const char *key)); +DEF_DLL_FN (void *, json_object_iter_next, (json_t *object, void *iter)); +DEF_DLL_FN (json_t *, json_loads, + (const char *input, size_t flags, json_error_t *error)); +DEF_DLL_FN (json_t *, json_load_callback, + (json_load_callback_t callback, void *data, size_t flags, + json_error_t *error)); + +/* This is called by json_decref, which is an inline function. */ +void json_delete(json_t *json) +{ + fn_json_delete (json); +} + +static bool json_initialized; + +static bool +init_json_functions (void) +{ + HMODULE library = w32_delayed_load (Qjson); + + if (!library) + return false; + + LOAD_DLL_FN (library, json_set_alloc_funcs); + LOAD_DLL_FN (library, json_delete); + LOAD_DLL_FN (library, json_array); + LOAD_DLL_FN (library, json_array_append_new); + LOAD_DLL_FN (library, json_array_size); + LOAD_DLL_FN (library, json_object); + LOAD_DLL_FN (library, json_object_set_new); + LOAD_DLL_FN (library, json_null); + LOAD_DLL_FN (library, json_true); + LOAD_DLL_FN (library, json_false); + LOAD_DLL_FN (library, json_integer); + LOAD_DLL_FN (library, json_real); + LOAD_DLL_FN (library, json_stringn); + LOAD_DLL_FN (library, json_dumps); + LOAD_DLL_FN (library, json_dump_callback); + LOAD_DLL_FN (library, json_integer_value); + LOAD_DLL_FN (library, json_real_value); + LOAD_DLL_FN (library, json_string_value); + LOAD_DLL_FN (library, json_string_length); + LOAD_DLL_FN (library, json_array_get); + LOAD_DLL_FN (library, json_object_get); + LOAD_DLL_FN (library, json_object_size); + LOAD_DLL_FN (library, json_object_iter_key); + LOAD_DLL_FN (library, json_object_iter); + LOAD_DLL_FN (library, json_object_iter_value); + LOAD_DLL_FN (library, json_object_key_to_iter); + LOAD_DLL_FN (library, json_object_iter_next); + LOAD_DLL_FN (library, json_loads); + LOAD_DLL_FN (library, json_load_callback); + + init_json (); + + return true; +} + +#define json_set_alloc_funcs fn_json_set_alloc_funcs +#define json_array fn_json_array +#define json_array_append_new fn_json_array_append_new +#define json_array_size fn_json_array_size +#define json_object fn_json_object +#define json_object_set_new fn_json_object_set_new +#define json_null fn_json_null +#define json_true fn_json_true +#define json_false fn_json_false +#define json_integer fn_json_integer +#define json_real fn_json_real +#define json_stringn fn_json_stringn +#define json_dumps fn_json_dumps +#define json_dump_callback fn_json_dump_callback +#define json_integer_value fn_json_integer_value +#define json_real_value fn_json_real_value +#define json_string_value fn_json_string_value +#define json_string_length fn_json_string_length +#define json_array_get fn_json_array_get +#define json_object_get fn_json_object_get +#define json_object_size fn_json_object_size +#define json_object_iter_key fn_json_object_iter_key +#define json_object_iter fn_json_object_iter +#define json_object_iter_value fn_json_object_iter_value +#define json_object_key_to_iter fn_json_object_key_to_iter +#define json_object_iter_next fn_json_object_iter_next +#define json_loads fn_json_loads +#define json_load_callback fn_json_load_callback + +#endif /* WINDOWSNT */ + +/* We install a custom allocator so that we can avoid objects larger + than PTRDIFF_MAX. Such objects wouldn't play well with the rest of + Emacs's codebase, which generally uses ptrdiff_t for sizes and + indices. The other functions in this file also generally assume + that size_t values never exceed PTRDIFF_MAX. */ + +static void * +json_malloc (size_t size) +{ + if (size > PTRDIFF_MAX) + { + errno = ENOMEM; + return NULL; + } + return malloc (size); +} + +static void +json_free (void *ptr) +{ + free (ptr); +} + +void +init_json (void) +{ + json_set_alloc_funcs (json_malloc, json_free); +} + +#if !JSON_HAS_ERROR_CODE + +/* Return whether STRING starts with PREFIX. */ + +static bool +json_has_prefix (const char *string, const char *prefix) +{ + size_t string_len = strlen (string); + size_t prefix_len = strlen (prefix); + return string_len >= prefix_len && memcmp (string, prefix, prefix_len) == 0; +} + +/* Return whether STRING ends with SUFFIX. */ + +static bool +json_has_suffix (const char *string, const char *suffix) +{ + size_t string_len = strlen (string); + size_t suffix_len = strlen (suffix); + return string_len >= suffix_len + && memcmp (string + string_len - suffix_len, suffix, suffix_len) == 0; +} + +#endif + +/* Create a multibyte Lisp string from the UTF-8 string in + [DATA, DATA + SIZE). If the range [DATA, DATA + SIZE) does not + contain a valid UTF-8 string, an unspecified string is returned. + Note that all callers below either pass only value UTF-8 strings or + use this function for formatting error messages; in the latter case + correctness isn't critical. */ + +static Lisp_Object +json_make_string (const char *data, ptrdiff_t size) +{ + return code_convert_string (make_specified_string (data, -1, size, false), + Qutf_8_unix, Qt, false, true, true); +} + +/* Create a multibyte Lisp string from the null-terminated UTF-8 + string beginning at DATA. If the string is not a valid UTF-8 + string, an unspecified string is returned. Note that all callers + below either pass only value UTF-8 strings or use this function for + formatting error messages; in the latter case correctness isn't + critical. */ + +static Lisp_Object +json_build_string (const char *data) +{ + return json_make_string (data, strlen (data)); +} + +/* Return a unibyte string containing the sequence of UTF-8 encoding + units of the UTF-8 representation of STRING. If STRING does not + represent a sequence of Unicode scalar values, return a string with + unspecified contents. */ + +static Lisp_Object +json_encode (Lisp_Object string) +{ + /* FIXME: Raise an error if STRING is not a scalar value + sequence. */ + return code_convert_string (string, Qutf_8_unix, Qt, true, true, true); +} + +static _Noreturn void +json_out_of_memory (void) +{ + xsignal0 (Qjson_out_of_memory); +} + +/* Signal a Lisp error corresponding to the JSON ERROR. */ + +static _Noreturn void +json_parse_error (const json_error_t *error) +{ + Lisp_Object symbol; +#if JSON_HAS_ERROR_CODE + switch (json_error_code (error)) + { + case json_error_premature_end_of_input: + symbol = Qjson_end_of_file; + break; + case json_error_end_of_input_expected: + symbol = Qjson_trailing_content; + break; + default: + symbol = Qjson_parse_error; + break; + } +#else + if (json_has_suffix (error->text, "expected near end of file")) + symbol = Qjson_end_of_file; + else if (json_has_prefix (error->text, "end of file expected")) + symbol = Qjson_trailing_content; + else + symbol = Qjson_parse_error; +#endif + xsignal (symbol, + list5 (json_build_string (error->text), + json_build_string (error->source), make_natnum (error->line), + make_natnum (error->column), make_natnum (error->position))); +} + +static void +json_release_object (void *object) +{ + json_decref (object); +} + +/* Signal an error if OBJECT is not a string, or if OBJECT contains + embedded null characters. */ + +static void +check_string_without_embedded_nulls (Lisp_Object object) +{ + CHECK_STRING (object); + CHECK_TYPE (memchr (SDATA (object), '\0', SBYTES (object)) == NULL, + Qstring_without_embedded_nulls_p, object); +} + +/* Signal an error of type `json-out-of-memory' if OBJECT is + NULL. */ + +static json_t * +json_check (json_t *object) +{ + if (object == NULL) + json_out_of_memory (); + return object; +} + +/* If STRING is not a valid UTF-8 string, signal an error of type + `wrong-type-argument'. STRING must be a unibyte string. */ + +static void +json_check_utf8 (Lisp_Object string) +{ + CHECK_TYPE (utf8_string_p (string), Qutf_8_string_p, string); +} + +static json_t *lisp_to_json (Lisp_Object); + +/* Convert a Lisp object to a toplevel JSON object (array or object). + This returns Lisp_Object so we can use unbind_to. The return value + is always nil. */ + +static _GL_ARG_NONNULL ((2)) Lisp_Object +lisp_to_json_toplevel_1 (Lisp_Object lisp, json_t **json) +{ + if (VECTORP (lisp)) + { + ptrdiff_t size = ASIZE (lisp); + *json = json_check (json_array ()); + ptrdiff_t count = SPECPDL_INDEX (); + record_unwind_protect_ptr (json_release_object, json); + for (ptrdiff_t i = 0; i < size; ++i) + { + int status + = json_array_append_new (*json, lisp_to_json (AREF (lisp, i))); + if (status == -1) + json_out_of_memory (); + } + eassert (json_array_size (*json) == size); + clear_unwind_protect (count); + return unbind_to (count, Qnil); + } + else if (HASH_TABLE_P (lisp)) + { + struct Lisp_Hash_Table *h = XHASH_TABLE (lisp); + *json = json_check (json_object ()); + ptrdiff_t count = SPECPDL_INDEX (); + record_unwind_protect_ptr (json_release_object, *json); + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i) + if (!NILP (HASH_HASH (h, i))) + { + Lisp_Object key = json_encode (HASH_KEY (h, i)); + /* We can't specify the length, so the string must be + null-terminated. */ + check_string_without_embedded_nulls (key); + const char *key_str = SSDATA (key); + /* Reject duplicate keys. These are possible if the hash + table test is not `equal'. */ + if (json_object_get (*json, key_str) != NULL) + wrong_type_argument (Qjson_value_p, lisp); + int status = json_object_set_new (*json, key_str, + lisp_to_json (HASH_VALUE (h, i))); + if (status == -1) + { + /* A failure can be caused either by an invalid key or + by low memory. */ + json_check_utf8 (key); + json_out_of_memory (); + } + } + clear_unwind_protect (count); + return unbind_to (count, Qnil); + } + else if (NILP (lisp)) + { + *json = json_check (json_object ()); + return Qnil; + } + else if (CONSP (lisp)) + { + Lisp_Object tail = lisp; + *json = json_check (json_object ()); + ptrdiff_t count = SPECPDL_INDEX (); + record_unwind_protect_ptr (json_release_object, *json); + FOR_EACH_TAIL (tail) + { + Lisp_Object pair = XCAR (tail); + CHECK_CONS (pair); + Lisp_Object key_symbol = XCAR (pair); + Lisp_Object value = XCDR (pair); + CHECK_SYMBOL (key_symbol); + Lisp_Object key = SYMBOL_NAME (key_symbol); + /* We can't specify the length, so the string must be + null-terminated. */ + check_string_without_embedded_nulls (key); + const char *key_str = SSDATA (key); + /* Only add element if key is not already present. */ + if (json_object_get (*json, key_str) == NULL) + { + int status + = json_object_set_new (*json, key_str, lisp_to_json (value)); + if (status == -1) + json_out_of_memory (); + } + } + CHECK_LIST_END (tail, lisp); + clear_unwind_protect (count); + return unbind_to (count, Qnil); + } + wrong_type_argument (Qjson_value_p, lisp); +} + +/* Convert LISP to a toplevel JSON object (array or object). Signal + an error of type `wrong-type-argument' if LISP is not a vector, + hashtable, or alist. */ + +static json_t * +lisp_to_json_toplevel (Lisp_Object lisp) +{ + if (++lisp_eval_depth > max_lisp_eval_depth) + xsignal0 (Qjson_object_too_deep); + json_t *json; + lisp_to_json_toplevel_1 (lisp, &json); + --lisp_eval_depth; + return json; +} + +/* Convert LISP to any JSON object. Signal an error of type + `wrong-type-argument' if the type of LISP can't be converted to a + JSON object. */ + +static json_t * +lisp_to_json (Lisp_Object lisp) +{ + if (EQ (lisp, QCnull)) + return json_check (json_null ()); + else if (EQ (lisp, QCfalse)) + return json_check (json_false ()); + else if (EQ (lisp, Qt)) + return json_check (json_true ()); + else if (INTEGERP (lisp)) + { + CHECK_TYPE_RANGED_INTEGER (json_int_t, lisp); + return json_check (json_integer (XINT (lisp))); + } + else if (FLOATP (lisp)) + return json_check (json_real (XFLOAT_DATA (lisp))); + else if (STRINGP (lisp)) + { + Lisp_Object encoded = json_encode (lisp); + json_t *json = json_stringn (SSDATA (encoded), SBYTES (encoded)); + if (json == NULL) + { + /* A failure can be caused either by an invalid string or by + low memory. */ + json_check_utf8 (encoded); + json_out_of_memory (); + } + return json; + } + + /* LISP now must be a vector, hashtable, or alist. */ + return lisp_to_json_toplevel (lisp); +} + +DEFUN ("json-serialize", Fjson_serialize, Sjson_serialize, 1, 1, NULL, + doc: /* Return the JSON representation of OBJECT as a string. +OBJECT must be a vector, hashtable, or alist, and its elements can +recursively contain `:null', `:false', t, numbers, strings, or other +vectors hashtables, and alist. `:null', `:false', and t will be +converted to JSON null, false, and true values, respectively. Vectors +will be converted to JSON arrays, and hashtables and alists to JSON +objects. Hashtable keys must be strings without embedded null +characters and must be unique within each object. Alist keys must be +symbols; if a key is duplicate, the first instance is used. */) + (Lisp_Object object) +{ + ptrdiff_t count = SPECPDL_INDEX (); + +#ifdef WINDOWSNT + if (!json_initialized) + { + Lisp_Object status; + json_initialized = init_json_functions (); + status = json_initialized ? Qt : Qnil; + Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache); + } + if (!json_initialized) + { + message1 ("jansson library not found"); + return Qnil; + } +#endif + + json_t *json = lisp_to_json_toplevel (object); + record_unwind_protect_ptr (json_release_object, json); + + /* If desired, we might want to add the following flags: + JSON_DECODE_ANY, JSON_ALLOW_NUL. */ + char *string = json_dumps (json, JSON_COMPACT); + if (string == NULL) + json_out_of_memory (); + record_unwind_protect_ptr (free, string); + + return unbind_to (count, json_build_string (string)); +} + +struct json_buffer_and_size +{ + const char *buffer; + ptrdiff_t size; +}; + +static Lisp_Object +json_insert (void *data) +{ + struct json_buffer_and_size *buffer_and_size = data; + /* FIXME: This should be possible without creating an intermediate + string object. */ + Lisp_Object string + = json_make_string (buffer_and_size->buffer, buffer_and_size->size); + insert1 (string); + return Qnil; +} + +struct json_insert_data +{ + /* nil if json_insert succeeded, otherwise the symbol + Qcatch_all_memory_full or a cons (ERROR-SYMBOL . ERROR-DATA). */ + Lisp_Object error; +}; + +/* Callback for json_dump_callback that inserts the UTF-8 string in + [BUFFER, BUFFER + SIZE) into the current buffer. + If [BUFFER, BUFFER + SIZE) does not contain a valid UTF-8 string, + an unspecified string is inserted into the buffer. DATA must point + to a structure of type json_insert_data. This function may not + exit nonlocally. It catches all nonlocal exits and stores them in + data->error for reraising. */ + +static int +json_insert_callback (const char *buffer, size_t size, void *data) +{ + struct json_insert_data *d = data; + struct json_buffer_and_size buffer_and_size + = {.buffer = buffer, .size = size}; + d->error = internal_catch_all (json_insert, &buffer_and_size, Fidentity); + return NILP (d->error) ? 0 : -1; +} + +DEFUN ("json-insert", Fjson_insert, Sjson_insert, 1, 1, NULL, + doc: /* Insert the JSON representation of OBJECT before point. +This is the same as (insert (json-serialize OBJECT)), but potentially +faster. See the function `json-serialize' for allowed values of +OBJECT. */) + (Lisp_Object object) +{ + ptrdiff_t count = SPECPDL_INDEX (); + +#ifdef WINDOWSNT + if (!json_initialized) + { + Lisp_Object status; + json_initialized = init_json_functions (); + status = json_initialized ? Qt : Qnil; + Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache); + } + if (!json_initialized) + { + message1 ("jansson library not found"); + return Qnil; + } +#endif + + json_t *json = lisp_to_json (object); + record_unwind_protect_ptr (json_release_object, json); + + struct json_insert_data data; + /* If desired, we might want to add the following flags: + JSON_DECODE_ANY, JSON_ALLOW_NUL. */ + int status + = json_dump_callback (json, json_insert_callback, &data, JSON_COMPACT); + if (status == -1) + { + if (CONSP (data.error)) + xsignal (XCAR (data.error), XCDR (data.error)); + else + json_out_of_memory (); + } + + return unbind_to (count, Qnil); +} + +enum json_object_type { + json_object_hashtable, + json_object_alist, +}; + +/* Convert a JSON object to a Lisp object. */ + +static _GL_ARG_NONNULL ((1)) Lisp_Object +json_to_lisp (json_t *json, enum json_object_type object_type) +{ + switch (json_typeof (json)) + { + case JSON_NULL: + return QCnull; + case JSON_FALSE: + return QCfalse; + case JSON_TRUE: + return Qt; + case JSON_INTEGER: + /* Return an integer if possible, a floating-point number + otherwise. This loses precision for integers with large + magnitude; however, such integers tend to be nonportable + anyway because many JSON implementations use only 64-bit + floating-point numbers with 53 mantissa bits. See + https://tools.ietf.org/html/rfc7159#section-6 for some + discussion. */ + return make_fixnum_or_float (json_integer_value (json)); + case JSON_REAL: + return make_float (json_real_value (json)); + case JSON_STRING: + return json_make_string (json_string_value (json), + json_string_length (json)); + case JSON_ARRAY: + { + if (++lisp_eval_depth > max_lisp_eval_depth) + xsignal0 (Qjson_object_too_deep); + size_t size = json_array_size (json); + if (FIXNUM_OVERFLOW_P (size)) + xsignal0 (Qoverflow_error); + Lisp_Object result = Fmake_vector (make_natnum (size), Qunbound); + for (ptrdiff_t i = 0; i < size; ++i) + ASET (result, i, + json_to_lisp (json_array_get (json, i), object_type)); + --lisp_eval_depth; + return result; + } + case JSON_OBJECT: + { + if (++lisp_eval_depth > max_lisp_eval_depth) + xsignal0 (Qjson_object_too_deep); + Lisp_Object result; + switch (object_type) + { + case json_object_hashtable: + { + size_t size = json_object_size (json); + if (FIXNUM_OVERFLOW_P (size)) + xsignal0 (Qoverflow_error); + result = CALLN (Fmake_hash_table, QCtest, Qequal, QCsize, + make_natnum (size)); + struct Lisp_Hash_Table *h = XHASH_TABLE (result); + const char *key_str; + json_t *value; + json_object_foreach (json, key_str, value) + { + Lisp_Object key = json_build_string (key_str); + EMACS_UINT hash; + ptrdiff_t i = hash_lookup (h, key, &hash); + /* Keys in JSON objects are unique, so the key can't + be present yet. */ + eassert (i < 0); + hash_put (h, key, json_to_lisp (value, object_type), hash); + } + break; + } + case json_object_alist: + { + result = Qnil; + const char *key_str; + json_t *value; + json_object_foreach (json, key_str, value) + { + Lisp_Object key = Fintern (json_build_string (key_str), Qnil); + result + = Fcons (Fcons (key, json_to_lisp (value, object_type)), + result); + } + result = Fnreverse (result); + break; + } + default: + /* Can't get here. */ + emacs_abort (); + } + --lisp_eval_depth; + return result; + } + } + /* Can't get here. */ + emacs_abort (); +} + +static enum json_object_type +json_parse_object_type (ptrdiff_t nargs, Lisp_Object *args) +{ + switch (nargs) + { + case 0: + return json_object_hashtable; + case 2: + { + Lisp_Object key = args[0]; + Lisp_Object value = args[1]; + if (!EQ (key, QCobject_type)) + wrong_choice (list1 (QCobject_type), key); + if (EQ (value, Qhash_table)) + return json_object_hashtable; + else if (EQ (value, Qalist)) + return json_object_alist; + else + wrong_choice (list2 (Qhash_table, Qalist), value); + } + default: + wrong_type_argument (Qplistp, Flist (nargs, args)); + } +} + +DEFUN ("json-parse-string", Fjson_parse_string, Sjson_parse_string, 1, MANY, + NULL, + doc: /* Parse the JSON STRING into a Lisp object. +This is essentially the reverse operation of `json-serialize', which +see. The returned object will be a vector, hashtable, or alist. Its +elements will be `:null', `:false', t, numbers, strings, or further +vectors, hashtables, and alists. If there are duplicate keys in an +object, all but the last one are ignored. If STRING doesn't contain a +valid JSON object, an error of type `json-parse-error' is signaled. +The keyword argument `:object-type' specifies which Lisp type is used +to represent objects; it can be `hash-table' or `alist'. +usage: (string &key (OBJECT-TYPE \\='hash-table)) */) + (ptrdiff_t nargs, Lisp_Object *args) +{ + ptrdiff_t count = SPECPDL_INDEX (); + +#ifdef WINDOWSNT + if (!json_initialized) + { + Lisp_Object status; + json_initialized = init_json_functions (); + status = json_initialized ? Qt : Qnil; + Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache); + } + if (!json_initialized) + { + message1 ("jansson library not found"); + return Qnil; + } +#endif + + Lisp_Object string = args[0]; + Lisp_Object encoded = json_encode (string); + check_string_without_embedded_nulls (encoded); + enum json_object_type object_type + = json_parse_object_type (nargs - 1, args + 1); + + json_error_t error; + json_t *object = json_loads (SSDATA (encoded), 0, &error); + if (object == NULL) + json_parse_error (&error); + + /* Avoid leaking the object in case of further errors. */ + if (object != NULL) + record_unwind_protect_ptr (json_release_object, object); + + return unbind_to (count, json_to_lisp (object, object_type)); +} + +struct json_read_buffer_data +{ + /* Byte position of position to read the next chunk from. */ + ptrdiff_t point; +}; + +/* Callback for json_load_callback that reads from the current buffer. + DATA must point to a structure of type json_read_buffer_data. + data->point must point to the byte position to read from; after + reading, data->point is advanced accordingly. The buffer point + itself is ignored. This function may not exit nonlocally. */ + +static size_t +json_read_buffer_callback (void *buffer, size_t buflen, void *data) +{ + struct json_read_buffer_data *d = data; + + /* First, parse from point to the gap or the end of the accessible + portion, whatever is closer. */ + ptrdiff_t point = d->point; + ptrdiff_t end = BUFFER_CEILING_OF (point) + 1; + ptrdiff_t count = end - point; + if (buflen < count) + count = buflen; + memcpy (buffer, BYTE_POS_ADDR (point), count); + d->point += count; + return count; +} + +DEFUN ("json-parse-buffer", Fjson_parse_buffer, Sjson_parse_buffer, + 0, MANY, NULL, + doc: /* Read JSON object from current buffer starting at point. +This is similar to `json-parse-string', which see. Move point after +the end of the object if parsing was successful. On error, point is +not moved. +usage: (&key (OBJECT-TYPE \\='hash-table)) */) + (ptrdiff_t nargs, Lisp_Object *args) +{ + ptrdiff_t count = SPECPDL_INDEX (); + +#ifdef WINDOWSNT + if (!json_initialized) + { + Lisp_Object status; + json_initialized = init_json_functions (); + status = json_initialized ? Qt : Qnil; + Vlibrary_cache = Fcons (Fcons (Qjson, status), Vlibrary_cache); + } + if (!json_initialized) + { + message1 ("jansson library not found"); + return Qnil; + } +#endif + + enum json_object_type object_type = json_parse_object_type (nargs, args); + + ptrdiff_t point = PT_BYTE; + struct json_read_buffer_data data = {.point = point}; + json_error_t error; + json_t *object = json_load_callback (json_read_buffer_callback, &data, + JSON_DISABLE_EOF_CHECK, &error); + + if (object == NULL) + json_parse_error (&error); + + /* Avoid leaking the object in case of further errors. */ + record_unwind_protect_ptr (json_release_object, object); + + /* Convert and then move point only if everything succeeded. */ + Lisp_Object lisp = json_to_lisp (object, object_type); + + /* Adjust point by how much we just read. */ + point += error.position; + SET_PT_BOTH (BYTE_TO_CHAR (point), point); + + return unbind_to (count, lisp); +} + +/* Simplified version of 'define-error' that works with pure + objects. */ + +static void +define_error (Lisp_Object name, const char *message, Lisp_Object parent) +{ + eassert (SYMBOLP (name)); + eassert (SYMBOLP (parent)); + Lisp_Object parent_conditions = Fget (parent, Qerror_conditions); + eassert (CONSP (parent_conditions)); + eassert (!NILP (Fmemq (parent, parent_conditions))); + eassert (NILP (Fmemq (name, parent_conditions))); + Fput (name, Qerror_conditions, pure_cons (name, parent_conditions)); + Fput (name, Qerror_message, build_pure_c_string (message)); +} + +void +syms_of_json (void) +{ + DEFSYM (QCnull, ":null"); + DEFSYM (QCfalse, ":false"); + + 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"); + DEFSYM (Qjson_parse_error, "json-parse-error"); + DEFSYM (Qjson_end_of_file, "json-end-of-file"); + DEFSYM (Qjson_trailing_content, "json-trailing-content"); + DEFSYM (Qjson_object_too_deep, "json-object-too-deep"); + define_error (Qjson_error, "generic JSON error", Qerror); + define_error (Qjson_out_of_memory, + "not enough memory for creating JSON object", Qjson_error); + define_error (Qjson_parse_error, "could not parse JSON stream", + Qjson_error); + define_error (Qjson_end_of_file, "end of JSON stream", Qjson_parse_error); + define_error (Qjson_trailing_content, "trailing content after JSON stream", + Qjson_parse_error); + define_error (Qjson_object_too_deep, + "object cyclic or Lisp evaluation too deep", Qjson_error); + + DEFSYM (Qpure, "pure"); + DEFSYM (Qside_effect_free, "side-effect-free"); + + DEFSYM (Qjson_serialize, "json-serialize"); + DEFSYM (Qjson_parse_string, "json-parse-string"); + Fput (Qjson_serialize, Qpure, Qt); + Fput (Qjson_serialize, Qside_effect_free, Qt); + Fput (Qjson_parse_string, Qpure, Qt); + Fput (Qjson_parse_string, Qside_effect_free, Qt); + + DEFSYM (QCobject_type, ":object-type"); + DEFSYM (Qalist, "alist"); + + defsubr (&Sjson_serialize); + defsubr (&Sjson_insert); + defsubr (&Sjson_parse_string); + defsubr (&Sjson_parse_buffer); +} diff --git a/src/keyboard.c b/src/keyboard.c index 16744acba88..07392b7d495 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -43,6 +43,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "systime.h" #include "atimer.h" #include "process.h" +#include "menu.h" #include <errno.h> #ifdef HAVE_PTHREAD @@ -1365,6 +1366,7 @@ command_loop_1 (void) Vthis_command_keys_shift_translated = Qnil; /* Read next key sequence; i gets its length. */ + raw_keybuf_count = 0; i = read_key_sequence (keybuf, ARRAYELTS (keybuf), Qnil, 0, 1, 1, 0); @@ -1869,6 +1871,7 @@ int poll_suppress_count; static struct atimer *poll_timer; +#if defined CYGWIN || defined DOS_NT /* Poll for input, so that we catch a C-g if it comes in. */ void poll_for_input_1 (void) @@ -1877,6 +1880,7 @@ poll_for_input_1 (void) && !waiting_for_input) gobble_input (); } +#endif /* Timer callback function for poll_timer. TIMER is equal to poll_timer. */ @@ -1928,20 +1932,22 @@ start_polling (void) #endif } +#ifdef DOS_NT /* True if we are using polling to handle input asynchronously. */ bool input_polling_used (void) { -#ifdef POLL_FOR_INPUT +# ifdef POLL_FOR_INPUT /* XXX This condition was (read_socket_hook && !interrupt_input), but read_socket_hook is not global anymore. Let's pretend that it's always set. */ return !interrupt_input; -#else - return 0; -#endif +# else + return false; +# endif } +#endif /* Turn off polling. */ @@ -2809,6 +2815,9 @@ read_char (int commandflag, Lisp_Object map, if (EQ (c, make_number (-2))) return c; + + if (CONSP (c) && EQ (XCAR (c), Qt)) + c = XCDR (c); } non_reread: @@ -8450,7 +8459,7 @@ read_char_x_menu_prompt (Lisp_Object map, /* Display the menu and get the selection. */ Lisp_Object value; - value = Fx_popup_menu (prev_event, get_keymap (map, 0, 1)); + value = x_popup_menu_1 (prev_event, get_keymap (map, 0, 1)); if (CONSP (value)) { Lisp_Object tem; @@ -8860,6 +8869,11 @@ test_undefined (Lisp_Object binding) && EQ (Fcommand_remapping (binding, Qnil, Qnil), Qundefined))); } +void init_raw_keybuf_count (void) +{ + raw_keybuf_count = 0; +} + /* Read a sequence of keys that ends with a non prefix character, storing it in KEYBUF, a buffer of size BUFSIZE. Prompt with PROMPT. @@ -8916,7 +8930,6 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, ptrdiff_t keys_start; Lisp_Object current_binding = Qnil; - Lisp_Object first_event = Qnil; /* Index of the first key that has no binding. It is useless to try fkey.start larger than that. */ @@ -8971,7 +8984,11 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, /* List of events for which a fake prefix key has been generated. */ Lisp_Object fake_prefixed_keys = Qnil; - raw_keybuf_count = 0; + /* raw_keybuf_count is now initialized in (most of) the callers of + read_key_sequence. This is so that in a recursive call (for + mouse menus) a spurious initialization doesn't erase the contents + of raw_keybuf created by the outer call. */ + /* raw_keybuf_count = 0; */ last_nonmenu_event = Qnil; @@ -9026,6 +9043,7 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, starting_buffer = current_buffer; first_unbound = bufsize + 1; + Lisp_Object first_event = mock_input > 0 ? keybuf[0] : Qnil; /* Build our list of keymaps. If we recognize a function key and replace its escape sequence in @@ -9343,6 +9361,7 @@ read_key_sequence (Lisp_Object *keybuf, int bufsize, Lisp_Object prompt, && BUFFERP (XWINDOW (window)->contents) && XBUFFER (XWINDOW (window)->contents) != current_buffer) { + GROW_RAW_KEYBUF; ASET (raw_keybuf, raw_keybuf_count, key); raw_keybuf_count++; keybuf[t] = key; @@ -9837,6 +9856,7 @@ read_key_sequence_vs (Lisp_Object prompt, Lisp_Object continue_echo, cancel_hourglass (); #endif + raw_keybuf_count = 0; i = read_key_sequence (keybuf, ARRAYELTS (keybuf), prompt, ! NILP (dont_downcase_last), ! NILP (can_return_switch_frame), 0, 0); diff --git a/src/keyboard.h b/src/keyboard.h index 9106646ced2..cae949893f4 100644 --- a/src/keyboard.h +++ b/src/keyboard.h @@ -438,6 +438,7 @@ extern unsigned int timers_run; extern bool menu_separator_name_p (const char *); extern bool parse_menu_item (Lisp_Object, int); +extern void init_raw_keybuf_count (void); extern KBOARD *allocate_kboard (Lisp_Object); extern void delete_kboard (KBOARD *); extern void not_single_kboard_state (KBOARD *); diff --git a/src/lastfile.c b/src/lastfile.c index fe8ac85a320..ec5311158e5 100644 --- a/src/lastfile.c +++ b/src/lastfile.c @@ -49,9 +49,6 @@ char my_edata[] = "End of Emacs initialized data"; isn't always a separate section in NT executables). */ char my_endbss[1]; -/* The Alpha MSVC linker globally segregates all static and public bss - data, so we must take both into account to determine the true extent - of the bss area used by Emacs. */ static char _my_endbss[1]; char * my_endbss_static = _my_endbss; diff --git a/src/lisp.h b/src/lisp.h index 57e4f4b9853..3eb6e0d3c1d 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -277,6 +277,18 @@ DEFINE_GDB_SYMBOL_END (VALMASK) error !; #endif +/* Lisp_Word is a scalar word suitable for holding a tagged pointer or + integer. Usually it is a pointer to a deliberately-incomplete type + 'union Lisp_X'. However, it is EMACS_INT when Lisp_Objects and + pointers differ in width. */ + +#define LISP_WORDS_ARE_POINTERS (EMACS_INT_MAX == INTPTR_MAX) +#if LISP_WORDS_ARE_POINTERS +typedef union Lisp_X *Lisp_Word; +#else +typedef EMACS_INT Lisp_Word; +#endif + /* Some operations are so commonly executed that they are implemented as macros, not functions, because otherwise runtime performance would suffer too much when compiling with GCC without optimization. @@ -302,16 +314,37 @@ error !; functions, once "gcc -Og" (new to GCC 4.8) works well enough for Emacs developers. Maybe in the year 2020. See Bug#11935. - Commentary for these macros can be found near their corresponding - functions, below. */ - -#if CHECK_LISP_OBJECT_TYPE -# define lisp_h_XLI(o) ((o).i) -# define lisp_h_XIL(i) ((Lisp_Object) { i }) + For the macros that have corresponding functions (defined later), + see these functions for commentary. */ + +/* Convert among the various Lisp-related types: I for EMACS_INT, L + for Lisp_Object, P for void *. */ +#if !CHECK_LISP_OBJECT_TYPE +# if LISP_WORDS_ARE_POINTERS +# define lisp_h_XLI(o) ((EMACS_INT) (o)) +# define lisp_h_XIL(i) ((Lisp_Object) (i)) +# define lisp_h_XLP(o) ((void *) (o)) +# define lisp_h_XPL(p) ((Lisp_Object) (p)) +# else +# define lisp_h_XLI(o) (o) +# define lisp_h_XIL(i) (i) +# define lisp_h_XLP(o) ((void *) (uintptr_t) (o)) +# define lisp_h_XPL(p) ((Lisp_Object) (uintptr_t) (p)) +# endif #else -# define lisp_h_XLI(o) (o) -# define lisp_h_XIL(i) (i) +# if LISP_WORDS_ARE_POINTERS +# define lisp_h_XLI(o) ((EMACS_INT) (o).i) +# define lisp_h_XIL(i) ((Lisp_Object) {(Lisp_Word) (i)}) +# define lisp_h_XLP(o) ((void *) (o).i) +# define lisp_h_XPL(p) lisp_h_XIL (p) +# else +# define lisp_h_XLI(o) ((o).i) +# define lisp_h_XIL(i) ((Lisp_Object) {i}) +# define lisp_h_XLP(o) ((void *) (uintptr_t) (o).i) +# define lisp_h_XPL(p) ((Lisp_Object) {(uintptr_t) (p)}) +# endif #endif + #define lisp_h_CHECK_NUMBER(x) CHECK_TYPE (INTEGERP (x), Qintegerp, x) #define lisp_h_CHECK_SYMBOL(x) CHECK_TYPE (SYMBOLP (x), Qsymbolp, x) #define lisp_h_CHECK_TYPE(ok, predicate, x) \ @@ -346,14 +379,21 @@ error !; XIL ((EMACS_INT) (((EMACS_UINT) (n) << INTTYPEBITS) + Lisp_Int0)) # define lisp_h_XFASTINT(a) XINT (a) # define lisp_h_XINT(a) (XLI (a) >> INTTYPEBITS) -# define lisp_h_XSYMBOL(a) \ +# ifdef __CHKP__ +# define lisp_h_XSYMBOL(a) \ + (eassert (SYMBOLP (a)), \ + (struct Lisp_Symbol *) ((char *) XUNTAG (a, Lisp_Symbol) \ + + (intptr_t) lispsym)) +# else + /* If !__CHKP__ this is equivalent, and is a bit faster as of GCC 7. */ +# define lisp_h_XSYMBOL(a) \ (eassert (SYMBOLP (a)), \ (struct Lisp_Symbol *) ((intptr_t) XLI (a) - Lisp_Symbol \ + (char *) lispsym)) +# endif # define lisp_h_XTYPE(a) ((enum Lisp_Type) (XLI (a) & ~VALMASK)) # define lisp_h_XUNTAG(a, type) \ - __builtin_assume_aligned ((void *) (intptr_t) (XLI (a) - (type)), \ - GCALIGNMENT) + __builtin_assume_aligned ((char *) XLP (a) - (type), GCALIGNMENT) #endif /* When compiling via gcc -O0, define the key operations as macros, as @@ -370,6 +410,8 @@ error !; #if DEFINE_KEY_OPS_AS_MACROS # define XLI(o) lisp_h_XLI (o) # define XIL(i) lisp_h_XIL (i) +# define XLP(o) lisp_h_XLP (o) +# define XPL(p) lisp_h_XPL (p) # define CHECK_NUMBER(x) lisp_h_CHECK_NUMBER (x) # define CHECK_SYMBOL(x) lisp_h_CHECK_SYMBOL (x) # define CHECK_TYPE(ok, predicate, x) lisp_h_CHECK_TYPE (ok, predicate, x) @@ -416,9 +458,8 @@ error !; #define case_Lisp_Int case Lisp_Int0: case Lisp_Int1 /* Idea stolen from GDB. Pedantic GCC complains about enum bitfields, - MSVC doesn't support them, and xlc and Oracle Studio c99 complain - vociferously about them. */ -#if (defined __STRICT_ANSI__ || defined _MSC_VER || defined __IBMC__ \ + and xlc and Oracle Studio c99 complain vociferously about them. */ +#if (defined __STRICT_ANSI__ || defined __IBMC__ \ || (defined __SUNPRO_C && __STDC__)) #define ENUM_BF(TYPE) unsigned int #else @@ -544,22 +585,24 @@ enum Lisp_Fwd_Type your object -- this way, the same object could be used to represent several disparate C structures. */ -#ifdef CHECK_LISP_OBJECT_TYPE -typedef struct Lisp_Object { EMACS_INT i; } Lisp_Object; +/* A Lisp_Object is a tagged pointer or integer. Ordinarily it is a + Lisp_Word. However, if CHECK_LISP_OBJECT_TYPE, it is a wrapper + around Lisp_Word, to help catch thinkos like 'Lisp_Object x = 0;'. -#define LISP_INITIALLY(i) {i} + LISP_INITIALLY (W) initializes a Lisp object with a tagged value + that is a Lisp_Word W. It can be used in a static initializer. */ -#undef CHECK_LISP_OBJECT_TYPE +#ifdef CHECK_LISP_OBJECT_TYPE +typedef struct Lisp_Object { Lisp_Word i; } Lisp_Object; +# define LISP_INITIALLY(w) {w} +# undef CHECK_LISP_OBJECT_TYPE enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = true }; -#else /* CHECK_LISP_OBJECT_TYPE */ - -/* If a struct type is not wanted, define Lisp_Object as just a number. */ - -typedef EMACS_INT Lisp_Object; -#define LISP_INITIALLY(i) (i) +#else +typedef Lisp_Word Lisp_Object; +# define LISP_INITIALLY(w) (w) enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = false }; -#endif /* CHECK_LISP_OBJECT_TYPE */ +#endif /* Forward declarations. */ @@ -591,8 +634,10 @@ extern double extract_float (Lisp_Object); /* Low-level conversion and type checking. */ -/* Convert a Lisp_Object to the corresponding EMACS_INT and vice versa. - At the machine level, these operations are no-ops. */ +/* Convert among various types use to implement Lisp_Object. At the + machine level, these operations may widen or narrow their arguments + if pointers differ in width from EMACS_INT; otherwise they are + no-ops. */ INLINE EMACS_INT (XLI) (Lisp_Object o) @@ -606,6 +651,18 @@ INLINE Lisp_Object return lisp_h_XIL (i); } +INLINE void * +(XLP) (Lisp_Object o) +{ + return lisp_h_XLP (o); +} + +INLINE Lisp_Object +(XPL) (void *p) +{ + return lisp_h_XPL (p); +} + /* Extract A's type. */ INLINE enum Lisp_Type @@ -633,8 +690,9 @@ INLINE void * #if USE_LSB_TAG return lisp_h_XUNTAG (a, type); #else - intptr_t i = USE_LSB_TAG ? XLI (a) - type : XLI (a) & VALMASK; - return (void *) i; + EMACS_UINT utype = type; + char *p = XLP (a); + return p - (utype << (USE_LSB_TAG ? 0 : VALBITS)); #endif } @@ -745,35 +803,46 @@ verify (alignof (struct Lisp_Symbol) % GCALIGNMENT == 0); #define DEFUN_ARGS_8 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, \ Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object) -/* Yield a signed integer that contains TAG along with PTR. +/* Typedefs useful for implementing TAG_PTR. untagged_ptr represents + a pointer before tagging, and Lisp_Word_tag contains a + possibly-shifted tag to be added to an untagged_ptr to convert it + to a Lisp_Word. */ +#if LISP_WORDS_ARE_POINTERS +/* untagged_ptr is a pointer so that the compiler knows that TAG_PTR + yields a pointer; this can help with gcc -fcheck-pointer-bounds. + It is char * so that adding a tag uses simple machine addition. */ +typedef char *untagged_ptr; +typedef uintptr_t Lisp_Word_tag; +#else +/* untagged_ptr is an unsigned integer instead of a pointer, so that + it can be added to the possibly-wider Lisp_Word_tag type without + losing information. */ +typedef uintptr_t untagged_ptr; +typedef EMACS_UINT Lisp_Word_tag; +#endif - Sign-extend pointers when USE_LSB_TAG (this simplifies emacs-module.c), - and zero-extend otherwise (that’s a bit faster here). - Sign extension matters only when EMACS_INT is wider than a pointer. */ +/* An initializer for a Lisp_Object that contains TAG along with PTR. */ #define TAG_PTR(tag, ptr) \ - (USE_LSB_TAG \ - ? (intptr_t) (ptr) + (tag) \ - : (EMACS_INT) (((EMACS_UINT) (tag) << VALBITS) + (uintptr_t) (ptr))) - -/* Yield an integer that contains a symbol tag along with OFFSET. - OFFSET should be the offset in bytes from 'lispsym' to the symbol. */ -#define TAG_SYMOFFSET(offset) TAG_PTR (Lisp_Symbol, offset) - -/* XLI_BUILTIN_LISPSYM (iQwhatever) is equivalent to - XLI (builtin_lisp_symbol (Qwhatever)), - except the former expands to an integer constant expression. */ -#define XLI_BUILTIN_LISPSYM(iname) TAG_SYMOFFSET ((iname) * sizeof *lispsym) + LISP_INITIALLY ((Lisp_Word) \ + ((untagged_ptr) (ptr) \ + + ((Lisp_Word_tag) (tag) << (USE_LSB_TAG ? 0 : VALBITS)))) /* LISPSYM_INITIALLY (Qfoo) is equivalent to Qfoo except it is designed for use as an initializer, even for a constant initializer. */ -#define LISPSYM_INITIALLY(name) LISP_INITIALLY (XLI_BUILTIN_LISPSYM (i##name)) +#define LISPSYM_INITIALLY(name) \ + TAG_PTR (Lisp_Symbol, (char *) (intptr_t) ((i##name) * sizeof *lispsym)) /* Declare extern constants for Lisp symbols. These can be helpful when using a debugger like GDB, on older platforms where the debug - format does not represent C macros. */ -#define DEFINE_LISP_SYMBOL(name) \ - DEFINE_GDB_SYMBOL_BEGIN (Lisp_Object, name) \ - DEFINE_GDB_SYMBOL_END (LISPSYM_INITIALLY (name)) + format does not represent C macros. However, they are unbounded + and would just be asking for trouble if checking pointer bounds. */ +#ifdef __CHKP__ +# define DEFINE_LISP_SYMBOL(name) +#else +# define DEFINE_LISP_SYMBOL(name) \ + DEFINE_GDB_SYMBOL_BEGIN (Lisp_Object, name) \ + DEFINE_GDB_SYMBOL_END (LISPSYM_INITIALLY (name)) +#endif /* The index of the C-defined Lisp symbol SYM. This can be used in a static initializer. */ @@ -837,6 +906,11 @@ INLINE struct Lisp_Symbol * eassert (SYMBOLP (a)); intptr_t i = (intptr_t) XUNTAG (a, Lisp_Symbol); void *p = (char *) lispsym + i; +# ifdef __CHKP__ + /* Bypass pointer checking. Although this could be improved it is + probably not worth the trouble. */ + p = __builtin___bnd_set_ptr_bounds (p, sizeof (struct Lisp_Symbol)); +# endif return p; #endif } @@ -844,7 +918,20 @@ INLINE struct Lisp_Symbol * INLINE Lisp_Object make_lisp_symbol (struct Lisp_Symbol *sym) { - Lisp_Object a = XIL (TAG_SYMOFFSET ((char *) sym - (char *) lispsym)); +#ifdef __CHKP__ + /* Although '__builtin___bnd_narrow_ptr_bounds (sym, sym, sizeof *sym)' + should be more efficient, it runs afoul of GCC bug 83251 + <https://gcc.gnu.org/bugzilla/show_bug.cgi?id=83251>. + Also, attempting to call __builtin___bnd_chk_ptr_bounds (sym, sizeof *sym) + here seems to trigger a GCC bug, as yet undiagnosed. */ + char *addr = __builtin___bnd_set_ptr_bounds (sym, sizeof *sym); + char *symoffset = addr - (intptr_t) lispsym; +#else + /* If !__CHKP__, GCC 7 x86-64 generates faster code if lispsym is + cast to char * rather than to intptr_t. */ + char *symoffset = (char *) ((char *) sym - (char *) lispsym); +#endif + Lisp_Object a = TAG_PTR (Lisp_Symbol, symoffset); eassert (XSYMBOL (a) == sym); return a; } @@ -1062,7 +1149,7 @@ clip_to_bounds (ptrdiff_t lower, EMACS_INT num, ptrdiff_t upper) INLINE Lisp_Object make_lisp_ptr (void *ptr, enum Lisp_Type type) { - Lisp_Object a = XIL (TAG_PTR (type, ptr)); + Lisp_Object a = TAG_PTR (type, ptr); eassert (XTYPE (a) == type && XUNTAG (a, type) == ptr); return a; } @@ -1133,7 +1220,7 @@ XINTPTR (Lisp_Object a) INLINE Lisp_Object make_pointer_integer (void *p) { - Lisp_Object a = XIL (TAG_PTR (Lisp_Int0, p)); + Lisp_Object a = TAG_PTR (Lisp_Int0, p); eassert (INTEGERP (a) && XINTPTR (a) == p); return a; } @@ -1645,8 +1732,10 @@ gc_aset (Lisp_Object array, ptrdiff_t idx, Lisp_Object val) /* True, since Qnil's representation is zero. Every place in the code that assumes Qnil is zero should verify (NIL_IS_ZERO), to make it easy - to find such assumptions later if we change Qnil to be nonzero. */ -enum { NIL_IS_ZERO = XLI_BUILTIN_LISPSYM (iQnil) == 0 }; + to find such assumptions later if we change Qnil to be nonzero. + Test iQnil and Lisp_Symbol instead of Qnil directly, since the latter + is not suitable for use in an integer constant expression. */ +enum { NIL_IS_ZERO = iQnil == 0 && Lisp_Symbol == 0 }; /* Clear the object addressed by P, with size NBYTES, so that all its bytes are zero and all its Lisp values are nil. */ @@ -2960,23 +3049,12 @@ CHECK_NUMBER_CDR (Lisp_Object x) /* This version of DEFUN declares a function prototype with the right arguments, so we can catch errors with maxargs at compile-time. */ -#ifdef _MSC_VER -#define DEFUN(lname, fnname, sname, minargs, maxargs, intspec, doc) \ - Lisp_Object fnname DEFUN_ARGS_ ## maxargs ; \ - static struct Lisp_Subr sname = \ - { { (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) \ - | (sizeof (struct Lisp_Subr) / sizeof (EMACS_INT)) }, \ - { (Lisp_Object (__cdecl *)(void))fnname }, \ - minargs, maxargs, lname, intspec, 0}; \ - Lisp_Object fnname -#else /* not _MSC_VER */ #define DEFUN(lname, fnname, sname, minargs, maxargs, intspec, doc) \ static struct Lisp_Subr sname = \ { { PVEC_SUBR << PSEUDOVECTOR_AREA_BITS }, \ { .a ## maxargs = fnname }, \ minargs, maxargs, lname, intspec, 0}; \ Lisp_Object fnname -#endif /* defsubr (Sname); is how we define the symbol for function `name' at start-up time. */ @@ -3464,6 +3542,12 @@ extern int x_bitmap_mask (struct frame *, ptrdiff_t); extern void reset_image_types (void); extern void syms_of_image (void); +#ifdef HAVE_JSON +/* Defined in json.c. */ +extern void init_json (void); +extern void syms_of_json (void); +#endif + /* Defined in insdel.c. */ extern void move_gap_both (ptrdiff_t, ptrdiff_t); extern _Noreturn void buffer_overflow (void); @@ -3887,6 +3971,7 @@ extern Lisp_Object internal_condition_case_2 (Lisp_Object (*) (Lisp_Object, Lisp extern Lisp_Object internal_condition_case_n (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *, Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *)); +extern Lisp_Object internal_catch_all (Lisp_Object (*) (void *), void *, Lisp_Object (*) (Lisp_Object)); extern struct handler *push_handler (Lisp_Object, enum handlertype); extern struct handler *push_handler_nosignal (Lisp_Object, enum handlertype); extern void specbind (Lisp_Object, Lisp_Object); @@ -4422,9 +4507,9 @@ extern void syms_of_xterm (void); extern char *x_get_keysym_name (int); #endif /* HAVE_WINDOW_SYSTEM */ -#ifdef HAVE_LIBXML2 /* Defined in xml.c. */ extern void syms_of_xml (void); +#ifdef HAVE_LIBXML2 extern void xml_cleanup_parser (void); #endif diff --git a/src/lread.c b/src/lread.c index 45d60647bee..28d4bf9a4fe 100644 --- a/src/lread.c +++ b/src/lread.c @@ -147,10 +147,10 @@ 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 false, so we need not specbind it - or worry about what happens to it when there is an error. */ +/* 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 @@ -1003,13 +1003,15 @@ load_error_handler (Lisp_Object data) return Qnil; } -static void -load_warn_old_style_backquotes (Lisp_Object file) +static _Noreturn void +load_error_old_style_backquotes (void) { - if (!NILP (Vlread_old_style_backquotes)) + if (NILP (Vload_file_name)) + xsignal1 (Qerror, build_string ("Old-style backquotes detected!")); + else { AUTO_STRING (format, "Loading `%s': old-style backquotes detected!"); - CALLN (Fmessage, format, file); + xsignal1 (Qerror, CALLN (Fformat_message, format, Vload_file_name)); } } @@ -1282,10 +1284,6 @@ Return t if the file exists and loads successfully. */) version = -1; - /* Check for the presence of old-style quotes and warn about them. */ - specbind (Qlread_old_style_backquotes, Qnil); - record_unwind_protect (load_warn_old_style_backquotes, file); - /* Check for the presence of unescaped character literals and warn about them. */ specbind (Qlread_unescaped_character_literals, Qnil); @@ -2194,7 +2192,7 @@ read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end) Lisp_Object retval; readchar_count = 0; - new_backquote_flag = 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) @@ -2269,7 +2267,7 @@ read0 (Lisp_Object readcharfun) return val; xsignal1 (Qinvalid_read_syntax, - Fmake_string (make_number (1), make_number (c))); + Fmake_string (make_number (1), make_number (c), Qnil)); } /* Grow a read buffer BUF that contains OFFSET useful bytes of data, @@ -3178,10 +3176,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) first_in_list exception (old-style can still be obtained via "(\`" anyway). */ if (!new_backquote_flag && first_in_list && next_char == ' ') - { - Vlread_old_style_backquotes = Qt; - goto default_label; - } + load_error_old_style_backquotes (); else { Lisp_Object value; @@ -3232,10 +3227,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) return list2 (comma_type, value); } else - { - Vlread_old_style_backquotes = Qt; - goto default_label; - } + load_error_old_style_backquotes (); } case '?': { @@ -3423,7 +3415,6 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) row. */ FALLTHROUGH; default: - default_label: if (c <= 040) goto retry; if (c == NO_BREAK_SPACE) goto retry; @@ -4996,12 +4987,6 @@ variables, this must be set in the first line of a file. */); doc: /* List of buffers being read from by calls to `eval-buffer' and `eval-region'. */); Veval_buffer_list = Qnil; - DEFVAR_LISP ("lread--old-style-backquotes", Vlread_old_style_backquotes, - doc: /* Set to non-nil when `read' encounters an old-style backquote. -For internal use only. */); - Vlread_old_style_backquotes = Qnil; - DEFSYM (Qlread_old_style_backquotes, "lread--old-style-backquotes"); - DEFVAR_LISP ("lread--unescaped-character-literals", Vlread_unescaped_character_literals, doc: /* List of deprecated unescaped character literals encountered by `read'. @@ -5026,6 +5011,17 @@ 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)Backquotes', 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 dd7c50f2719..817071fa44f 100644 --- a/src/macfont.m +++ b/src/macfont.m @@ -1441,8 +1441,6 @@ macfont_get_glyph_for_character (struct font *font, UTF32Char c) CGGlyph *glyphs; int i, len; int nrows; - dispatch_queue_t queue; - dispatch_group_t group = NULL; int nkeys; if (row != 0) diff --git a/src/menu.c b/src/menu.c index d5e1638b7cd..93e793a5d91 100644 --- a/src/menu.c +++ b/src/menu.c @@ -1112,51 +1112,8 @@ into menu items. */) return Qnil; } - -DEFUN ("x-popup-menu", Fx_popup_menu, Sx_popup_menu, 2, 2, 0, - doc: /* Pop up a deck-of-cards menu and return user's selection. -POSITION is a position specification. This is either a mouse button event -or a list ((XOFFSET YOFFSET) WINDOW) -where XOFFSET and YOFFSET are positions in pixels from the top left -corner of WINDOW. (WINDOW may be a window or a frame object.) -This controls the position of the top left of the menu as a whole. -If POSITION is t, it means to use the current mouse position. - -MENU is a specifier for a menu. For the simplest case, MENU is a keymap. -The menu items come from key bindings that have a menu string as well as -a definition; actually, the "definition" in such a key binding looks like -\(STRING . REAL-DEFINITION). To give the menu a title, put a string into -the keymap as a top-level element. - -If REAL-DEFINITION is nil, that puts a nonselectable string in the menu. -Otherwise, REAL-DEFINITION should be a valid key binding definition. - -You can also use a list of keymaps as MENU. - Then each keymap makes a separate pane. - -When MENU is a keymap or a list of keymaps, the return value is the -list of events corresponding to the user's choice. Note that -`x-popup-menu' does not actually execute the command bound to that -sequence of events. - -Alternatively, you can specify a menu of multiple panes - with a list of the form (TITLE PANE1 PANE2...), -where each pane is a list of form (TITLE ITEM1 ITEM2...). -Each ITEM is normally a cons cell (STRING . VALUE); -but a string can appear as an item--that makes a nonselectable line -in the menu. -With this form of menu, the return value is VALUE from the chosen item. - -If POSITION is nil, don't display the menu at all, just precalculate the -cached information about equivalent key sequences. - -If the user gets rid of the menu without making a valid choice, for -instance by clicking the mouse away from a valid choice or by typing -keyboard input, then this normally results in a quit and -`x-popup-menu' does not return. But if POSITION is a mouse button -event (indicating that the user invoked the menu with the mouse) then -no quit occurs and `x-popup-menu' returns nil. */) - (Lisp_Object position, Lisp_Object menu) +Lisp_Object +x_popup_menu_1 (Lisp_Object position, Lisp_Object menu) { Lisp_Object keymap, tem, tem2; int xpos = 0, ypos = 0; @@ -1443,6 +1400,55 @@ no quit occurs and `x-popup-menu' returns nil. */) return selection; } +DEFUN ("x-popup-menu", Fx_popup_menu, Sx_popup_menu, 2, 2, 0, + doc: /* Pop up a deck-of-cards menu and return user's selection. +POSITION is a position specification. This is either a mouse button event +or a list ((XOFFSET YOFFSET) WINDOW) +where XOFFSET and YOFFSET are positions in pixels from the top left +corner of WINDOW. (WINDOW may be a window or a frame object.) +This controls the position of the top left of the menu as a whole. +If POSITION is t, it means to use the current mouse position. + +MENU is a specifier for a menu. For the simplest case, MENU is a keymap. +The menu items come from key bindings that have a menu string as well as +a definition; actually, the "definition" in such a key binding looks like +\(STRING . REAL-DEFINITION). To give the menu a title, put a string into +the keymap as a top-level element. + +If REAL-DEFINITION is nil, that puts a nonselectable string in the menu. +Otherwise, REAL-DEFINITION should be a valid key binding definition. + +You can also use a list of keymaps as MENU. + Then each keymap makes a separate pane. + +When MENU is a keymap or a list of keymaps, the return value is the +list of events corresponding to the user's choice. Note that +`x-popup-menu' does not actually execute the command bound to that +sequence of events. + +Alternatively, you can specify a menu of multiple panes + with a list of the form (TITLE PANE1 PANE2...), +where each pane is a list of form (TITLE ITEM1 ITEM2...). +Each ITEM is normally a cons cell (STRING . VALUE); +but a string can appear as an item--that makes a nonselectable line +in the menu. +With this form of menu, the return value is VALUE from the chosen item. + +If POSITION is nil, don't display the menu at all, just precalculate the +cached information about equivalent key sequences. + +If the user gets rid of the menu without making a valid choice, for +instance by clicking the mouse away from a valid choice or by typing +keyboard input, then this normally results in a quit and +`x-popup-menu' does not return. But if POSITION is a mouse button +event (indicating that the user invoked the menu with the mouse) then +no quit occurs and `x-popup-menu' returns nil. */) + (Lisp_Object position, Lisp_Object menu) +{ + init_raw_keybuf_count (); + return x_popup_menu_1 (position, menu); +} + /* If F's terminal is not capable of displaying a popup dialog, emulate it with a menu. */ diff --git a/src/menu.h b/src/menu.h index 4c4ac83424f..104f6dc81d2 100644 --- a/src/menu.h +++ b/src/menu.h @@ -60,4 +60,5 @@ extern Lisp_Object ns_menu_show (struct frame *, int, int, int, extern Lisp_Object tty_menu_show (struct frame *, int, int, int, Lisp_Object, const char **); extern ptrdiff_t menu_item_width (const unsigned char *); +extern Lisp_Object x_popup_menu_1 (Lisp_Object position, Lisp_Object menu); #endif /* MENU_H */ diff --git a/src/msdos.c b/src/msdos.c index 94e975eaa21..eedbf7b1a6c 100644 --- a/src/msdos.c +++ b/src/msdos.c @@ -1791,7 +1791,7 @@ internal_terminal_init (void) } Vinitial_window_system = Qpc; - Vwindow_system_version = make_number (26); /* RE Emacs version */ + Vwindow_system_version = make_number (27); /* RE Emacs version */ tty->terminal->type = output_msdos_raw; /* If Emacs was dumped on DOS/V machine, forget the stale VRAM diff --git a/src/nsfns.m b/src/nsfns.m index 7f2f060dda8..c8b30246268 100644 --- a/src/nsfns.m +++ b/src/nsfns.m @@ -1896,10 +1896,12 @@ If omitted or nil, that stands for the selected frame's display. */) { case NSBackingStoreBuffered: return intern ("buffered"); +#if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 101300 case NSBackingStoreRetained: return intern ("retained"); case NSBackingStoreNonretained: return intern ("non-retained"); +#endif default: error ("Strange value for backingType parameter of frame"); } @@ -1953,9 +1955,11 @@ If omitted or nil, that stands for the selected frame's display. */) case NSBackingStoreBuffered: return Qt; +#if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 101300 case NSBackingStoreRetained: case NSBackingStoreNonretained: return Qnil; +#endif default: error ("Strange value for backingType parameter of frame"); @@ -2869,6 +2873,8 @@ Text larger than the specified size is clipped. */) struct frame *f; char *str; NSSize size; + NSColor *color; + Lisp_Object t; specbind (Qinhibit_redisplay, Qt); @@ -2896,6 +2902,14 @@ Text larger than the specified size is clipped. */) else Fx_hide_tip (); + t = x_get_arg (NULL, parms, Qbackground_color, NULL, NULL, RES_TYPE_STRING); + if (ns_lisp_to_color (t, &color) == 0) + [ns_tooltip setBackgroundColor: color]; + + t = x_get_arg (NULL, parms, Qforeground_color, NULL, NULL, RES_TYPE_STRING); + if (ns_lisp_to_color (t, &color) == 0) + [ns_tooltip setForegroundColor: color]; + [ns_tooltip setText: str]; size = [ns_tooltip frame].size; @@ -3121,6 +3135,19 @@ position (0, 0) of the selected frame's terminal. */) (pt.y - screen.frame.origin.y))); } +DEFUN ("ns-show-character-palette", + Fns_show_character_palette, + Sns_show_character_palette, 0, 0, 0, + doc: /* Show the macOS character palette. */) + (void) +{ + struct frame *f = SELECTED_FRAME (); + EmacsView *view = FRAME_NS_VIEW (f); + [NSApp orderFrontCharacterPalette:view]; + + return Qnil; +} + /* ========================================================================== Class implementations @@ -3312,6 +3339,7 @@ be used as the image of the icon representing the frame. */); defsubr (&Sns_frame_restack); defsubr (&Sns_set_mouse_absolute_pixel_position); defsubr (&Sns_mouse_absolute_pixel_position); + defsubr (&Sns_show_character_palette); defsubr (&Sx_display_mm_width); defsubr (&Sx_display_mm_height); defsubr (&Sx_display_screens); diff --git a/src/nsimage.m b/src/nsimage.m index 6bce61626ff..e9af58b8afa 100644 --- a/src/nsimage.m +++ b/src/nsimage.m @@ -76,8 +76,9 @@ ns_load_image (struct frame *f, struct image *img, { EmacsImage *eImg = nil; NSSize size; - Lisp_Object lisp_index; + Lisp_Object lisp_index, lisp_rotation; unsigned int index; + double rotation; NSTRACE ("ns_load_image"); @@ -86,6 +87,9 @@ ns_load_image (struct frame *f, struct image *img, lisp_index = Fplist_get (XCDR (img->spec), QCindex); index = INTEGERP (lisp_index) ? XFASTINT (lisp_index) : 0; + lisp_rotation = Fplist_get (XCDR (img->spec), QCrotation); + rotation = NUMBERP (lisp_rotation) ? XFLOATINT (lisp_rotation) : 0; + if (STRINGP (spec_file)) { eImg = [EmacsImage allocInitFromFile: spec_file]; @@ -113,6 +117,17 @@ ns_load_image (struct frame *f, struct image *img, return 0; } + img->lisp_data = [eImg getMetadata]; + + if (rotation != 0) + { + EmacsImage *temp = [eImg rotate:rotation]; + [eImg release]; + eImg = temp; + } + + [eImg setSizeFromSpec:XCDR (img->spec)]; + size = [eImg size]; img->width = size.width; img->height = size.height; @@ -120,7 +135,6 @@ ns_load_image (struct frame *f, struct image *img, /* 4) set img->pixmap = emacsimage */ img->pixmap = eImg; - img->lisp_data = [eImg getMetadata]; return 1; } @@ -510,4 +524,102 @@ ns_set_alpha (void *img, int x, int y, unsigned char a) return YES; } +- (void)setSizeFromSpec: (Lisp_Object) spec +{ + NSSize size = [self size]; + Lisp_Object value; + double scale = 1, aspect = size.width / size.height; + double width = -1, height = -1, max_width = -1, max_height = -1; + + value = Fplist_get (spec, QCscale); + if (NUMBERP (value)) + scale = XFLOATINT (value) ; + + value = Fplist_get (spec, QCmax_width); + if (NUMBERP (value)) + max_width = XFLOATINT (value); + + value = Fplist_get (spec, QCmax_height); + if (NUMBERP (value)) + max_height = XFLOATINT (value); + + value = Fplist_get (spec, QCwidth); + if (NUMBERP (value)) + { + width = XFLOATINT (value) * scale; + /* :width overrides :max-width. */ + max_width = -1; + } + + value = Fplist_get (spec, QCheight); + if (NUMBERP (value)) + { + height = XFLOATINT (value) * scale; + /* :height overrides :max-height. */ + max_height = -1; + } + + if (width <= 0 && height <= 0) + { + width = size.width * scale; + height = size.height * scale; + } + else if (width > 0 && height <= 0) + height = width / aspect; + else if (height > 0 && width <= 0) + width = height * aspect; + + if (max_width > 0 && width > max_width) + { + width = max_width; + height = max_width / aspect; + } + + if (max_height > 0 && height > max_height) + { + height = max_height; + width = max_height * aspect; + } + + [self setSize:NSMakeSize(width, height)]; +} + +- (instancetype)rotate: (double)rotation +{ + EmacsImage *new_image; + NSPoint new_origin; + NSSize new_size, size = [self size]; + NSRect rect = { NSZeroPoint, [self size] }; + + /* Create a bezier path of the outline of the image and do the + * rotation on it. */ + NSBezierPath *bounds_path = [NSBezierPath bezierPathWithRect:rect]; + NSAffineTransform *transform = [NSAffineTransform transform]; + [transform rotateByDegrees: rotation * -1]; + [bounds_path transformUsingAffineTransform:transform]; + + /* Now we can find out how large the rotated image needs to be. */ + new_size = [bounds_path bounds].size; + new_image = [[EmacsImage alloc] initWithSize:new_size]; + + new_origin = NSMakePoint((new_size.width - size.width)/2, + (new_size.height - size.height)/2); + + [new_image lockFocus]; + + /* Create the final transform. */ + transform = [NSAffineTransform transform]; + [transform translateXBy:new_size.width/2 yBy:new_size.height/2]; + [transform rotateByDegrees: rotation * -1]; + [transform translateXBy:-new_size.width/2 yBy:-new_size.height/2]; + + [transform concat]; + [self drawAtPoint:new_origin fromRect:NSZeroRect + operation:NSCompositingOperationCopy fraction:1]; + + [new_image unlockFocus]; + + return new_image; +} + @end diff --git a/src/nsmenu.m b/src/nsmenu.m index 20b4e58b479..5748b20ce81 100644 --- a/src/nsmenu.m +++ b/src/nsmenu.m @@ -1364,6 +1364,16 @@ update_frame_tool_bar (struct frame *f) [textField setFrame: r]; } +- (void) setBackgroundColor: (NSColor *)col +{ + [textField setBackgroundColor: col]; +} + +- (void) setForegroundColor: (NSColor *)col +{ + [textField setTextColor: col]; +} + - (void) showAtX: (int)x Y: (int)y for: (int)seconds { NSRect wr = [win frame]; diff --git a/src/nsselect.m b/src/nsselect.m index bee628b7576..d8b4e2c7af8 100644 --- a/src/nsselect.m +++ b/src/nsselect.m @@ -36,7 +36,7 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu) static Lisp_Object Vselection_alist; -/* NSGeneralPboard is pretty much analogous to X11 CLIPBOARD */ +/* NSPasteboardNameGeneral is pretty much analogous to X11 CLIPBOARD */ static NSString *NXPrimaryPboard; static NSString *NXSecondaryPboard; @@ -54,7 +54,7 @@ static NSString * symbol_to_nsstring (Lisp_Object sym) { CHECK_SYMBOL (sym); - if (EQ (sym, QCLIPBOARD)) return NSGeneralPboard; + if (EQ (sym, QCLIPBOARD)) return NSPasteboardNameGeneral; if (EQ (sym, QPRIMARY)) return NXPrimaryPboard; if (EQ (sym, QSECONDARY)) return NXSecondaryPboard; if (EQ (sym, QTEXT)) return NSStringPboardType; @@ -70,7 +70,7 @@ ns_symbol_to_pb (Lisp_Object symbol) static Lisp_Object ns_string_to_symbol (NSString *t) { - if ([t isEqualToString: NSGeneralPboard]) + if ([t isEqualToString: NSPasteboardNameGeneral]) return QCLIPBOARD; if ([t isEqualToString: NXPrimaryPboard]) return QPRIMARY; @@ -469,7 +469,7 @@ nxatoms_of_nsselect (void) pasteboard_changecount = [[NSMutableDictionary dictionaryWithObjectsAndKeys: - [NSNumber numberWithLong:0], NSGeneralPboard, + [NSNumber numberWithLong:0], NSPasteboardNameGeneral, [NSNumber numberWithLong:0], NXPrimaryPboard, [NSNumber numberWithLong:0], NXSecondaryPboard, [NSNumber numberWithLong:0], NSStringPboardType, diff --git a/src/nsterm.h b/src/nsterm.h index c40ddf3284a..878923cbb41 100644 --- a/src/nsterm.h +++ b/src/nsterm.h @@ -585,6 +585,8 @@ typedef id instancetype; } - (instancetype) init; - (void) setText: (char *)text; +- (void) setBackgroundColor: (NSColor *)col; +- (void) setForegroundColor: (NSColor *)col; - (void) showAtX: (int)x Y: (int)y for: (int)seconds; - (void) hide; - (BOOL) isActive; @@ -646,6 +648,8 @@ typedef id instancetype; - (NSColor *)stippleMask; - (Lisp_Object)getMetadata; - (BOOL)setFrame: (unsigned int) index; +- (void)setSizeFromSpec: (Lisp_Object) spec; +- (instancetype)rotate: (double)rotation; @end @@ -1306,6 +1310,7 @@ extern char gnustep_base_version[]; /* version tracking */ #define NSWindowStyleMaskUtilityWindow NSUtilityWindowMask #define NSAlertStyleCritical NSCriticalAlertStyle #define NSControlSizeRegular NSRegularControlSize +#define NSCompositingOperationCopy NSCompositeCopy /* And adds NSWindowStyleMask. */ #ifdef __OBJC__ @@ -1319,5 +1324,10 @@ enum NSWindowTabbingMode NSWindowTabbingModePreferred, NSWindowTabbingModeDisallowed }; +#endif /* !defined (NS_IMPL_COCOA) || !defined (MAC_OS_X_VERSION_10_12) */ + +#if !defined (NS_IMPL_COCOA) || !defined (MAC_OS_X_VERSION_10_13) +/* Deprecated in macOS 10.13. */ +#define NSPasteboardNameGeneral NSGeneralPboard #endif #endif /* HAVE_NS */ diff --git a/src/nsterm.m b/src/nsterm.m index 5798f4fd0b4..b80d832ee0b 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -6016,7 +6016,13 @@ not_in_argv (NSString *arg) if (!NSIsEmptyRect (visible)) [self addCursorRect: visible cursor: currentCursor]; - [currentCursor setOnMouseEntered: YES]; + +#if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 101300 +#if MAC_OS_X_VERSION_MAX_ALLOWED >= 101300 + if ([currentCursor respondsToSelector: @selector(setOnMouseEntered)]) +#endif + [currentCursor setOnMouseEntered: YES]; +#endif } @@ -6277,14 +6283,20 @@ not_in_argv (NSString *arg) by doCommandBySelector: deleteBackward: */ - (void)insertText: (id)aString { - int code; - int len = [(NSString *)aString length]; - int i; + NSString *s; + NSUInteger len; NSTRACE ("[EmacsView insertText:]"); + if ([aString isKindOfClass:[NSAttributedString class]]) + s = [aString string]; + else + s = aString; + + len = [s length]; + if (NS_KEYLOG) - NSLog (@"insertText '%@'\tlen = %d", aString, len); + NSLog (@"insertText '%@'\tlen = %lu", aString, (unsigned long) len); processingCompose = NO; if (!emacs_event) @@ -6294,10 +6306,24 @@ not_in_argv (NSString *arg) if (workingText != nil) [self deleteWorkingText]; + /* It might be preferable to use getCharacters:range: below, + cf. https://developer.apple.com/library/content/documentation/Cocoa/Conceptual/CocoaPerformance/Articles/StringDrawing.html#//apple_ref/doc/uid/TP40001445-112378. + However, we probably can't use SAFE_NALLOCA here because it might + exit nonlocally. */ + /* now insert the string as keystrokes */ - for (i =0; i<len; i++) + for (NSUInteger i = 0; i < len; i++) { - code = [aString characterAtIndex: i]; + NSUInteger code = [s characterAtIndex:i]; + if (UTF_16_HIGH_SURROGATE_P (code) && i < len - 1) + { + unichar low = [s characterAtIndex:i + 1]; + if (UTF_16_LOW_SURROGATE_P (low)) + { + code = surrogates_to_codepoint (low, code); + ++i; + } + } /* TODO: still need this? */ if (code == 0x2DC) code = '~'; /* 0x7E */ @@ -8746,7 +8772,14 @@ not_in_argv (NSString *arg) if (!NSIsEmptyRect (visible)) [self addCursorRect: visible cursor: [NSCursor arrowCursor]]; - [[NSCursor arrowCursor] setOnMouseEntered: YES]; + +#if defined (NS_IMPL_GNUSTEP) || MAC_OS_X_VERSION_MIN_REQUIRED < 101300 +#if MAC_OS_X_VERSION_MAX_ALLOWED >= 101300 + if ([[NSCursor arrowCursor] respondsToSelector: + @selector(setOnMouseEntered)]) +#endif + [[NSCursor arrowCursor] setOnMouseEntered: YES]; +#endif } diff --git a/src/process.c b/src/process.c index 94d9f8c6a5c..d4440e472d0 100644 --- a/src/process.c +++ b/src/process.c @@ -3835,7 +3835,6 @@ usage: (make-network-process &rest ARGS) */) Lisp_Object contact; struct Lisp_Process *p; const char *portstring UNINIT; - ptrdiff_t portstringlen ATTRIBUTE_UNUSED; char portbuf[INT_BUFSIZE_BOUND (EMACS_INT)]; #ifdef HAVE_LOCAL_SOCKETS struct sockaddr_un address_un; @@ -3982,6 +3981,8 @@ usage: (make-network-process &rest ARGS) */) if (!NILP (host)) { + ptrdiff_t portstringlen ATTRIBUTE_UNUSED; + /* SERVICE can either be a string or int. Convert to a C string for later use by getaddrinfo. */ if (EQ (service, Qt)) @@ -4000,37 +4001,38 @@ usage: (make-network-process &rest ARGS) */) portstring = SSDATA (service); portstringlen = SBYTES (service); } - } #ifdef HAVE_GETADDRINFO_A - if (!NILP (host) && !NILP (Fplist_get (contact, QCnowait))) - { - ptrdiff_t hostlen = SBYTES (host); - struct req - { - struct gaicb gaicb; - struct addrinfo hints; - char str[FLEXIBLE_ARRAY_MEMBER]; - } *req = xmalloc (FLEXSIZEOF (struct req, str, - hostlen + 1 + portstringlen + 1)); - dns_request = &req->gaicb; - dns_request->ar_name = req->str; - dns_request->ar_service = req->str + hostlen + 1; - dns_request->ar_request = &req->hints; - dns_request->ar_result = NULL; - memset (&req->hints, 0, sizeof req->hints); - req->hints.ai_family = family; - req->hints.ai_socktype = socktype; - strcpy (req->str, SSDATA (host)); - strcpy (req->str + hostlen + 1, portstring); - - int ret = getaddrinfo_a (GAI_NOWAIT, &dns_request, 1, NULL); - if (ret) - error ("%s/%s getaddrinfo_a error %d", SSDATA (host), portstring, ret); - - goto open_socket; - } + if (!NILP (Fplist_get (contact, QCnowait))) + { + ptrdiff_t hostlen = SBYTES (host); + struct req + { + struct gaicb gaicb; + struct addrinfo hints; + char str[FLEXIBLE_ARRAY_MEMBER]; + } *req = xmalloc (FLEXSIZEOF (struct req, str, + hostlen + 1 + portstringlen + 1)); + dns_request = &req->gaicb; + dns_request->ar_name = req->str; + dns_request->ar_service = req->str + hostlen + 1; + dns_request->ar_request = &req->hints; + dns_request->ar_result = NULL; + memset (&req->hints, 0, sizeof req->hints); + req->hints.ai_family = family; + req->hints.ai_socktype = socktype; + strcpy (req->str, SSDATA (host)); + strcpy (req->str + hostlen + 1, portstring); + + int ret = getaddrinfo_a (GAI_NOWAIT, &dns_request, 1, NULL); + if (ret) + error ("%s/%s getaddrinfo_a error %d", + SSDATA (host), portstring, ret); + + goto open_socket; + } #endif /* HAVE_GETADDRINFO_A */ + } /* If we have a host, use getaddrinfo to resolve both host and service. Otherwise, use getservbyname to lookup the service. */ @@ -5625,16 +5627,6 @@ wait_reading_process_output (intmax_t time_limit, int nsecs, int read_kbd, } else if (nread == -1 && would_block (errno)) ; -#ifdef WINDOWSNT - /* FIXME: Is this special case still needed? */ - /* Note that we cannot distinguish between no input - available now and a closed pipe. - With luck, a closed pipe will be accompanied by - subprocess termination and SIGCHLD. */ - else if (nread == 0 && !NETCONN_P (proc) && !SERIALCONN_P (proc) - && !PIPECONN_P (proc)) - ; -#endif #ifdef HAVE_PTYS /* On some OSs with ptys, when the process on one end of a pty exits, the other end gets an error reading with diff --git a/src/ptr-bounds.h b/src/ptr-bounds.h new file mode 100644 index 00000000000..8cbd58d72b0 --- /dev/null +++ b/src/ptr-bounds.h @@ -0,0 +1,79 @@ +/* Pointer bounds checking for GNU Emacs + +Copyright 2017-2018 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/>. */ + +/* Pointer bounds checking is a no-op unless running on hardware + supporting Intel MPX (Intel Skylake or better). Also, it requires + GCC 5 and Linux kernel 3.19, or later. Configure with + CFLAGS='-fcheck-pointer-bounds -mmpx', perhaps with + -fchkp-first-field-has-own-bounds thrown in. + + Although pointer bounds checking can help during debugging, it is + disabled by default because it hurts performance significantly. + The checking does not detect all pointer errors. For example, a + dumped Emacs might not detect a bounds violation of a pointer that + was created before Emacs was dumped. */ + +#ifndef PTR_BOUNDS_H +#define PTR_BOUNDS_H + +#include <stddef.h> + +/* When not checking pointer bounds, the following macros simply + return their first argument. These macros return either void *, or + the same type as their first argument. */ + +INLINE_HEADER_BEGIN + +/* Return a copy of P, with bounds narrowed to [P, P + N). */ +#ifdef __CHKP__ +INLINE void * +ptr_bounds_clip (void const *p, size_t n) +{ + return __builtin___bnd_narrow_ptr_bounds (p, p, n); +} +#else +# define ptr_bounds_clip(p, n) ((void) (size_t) {n}, p) +#endif + +/* Return a copy of P, but with the bounds of Q. */ +#ifdef __CHKP__ +# define ptr_bounds_copy(p, q) __builtin___bnd_copy_ptr_bounds (p, q) +#else +# define ptr_bounds_copy(p, q) ((void) (void const *) {q}, p) +#endif + +/* Return a copy of P, but with infinite bounds. + This is a loophole in pointer bounds checking. */ +#ifdef __CHKP__ +# define ptr_bounds_init(p) __builtin___bnd_init_ptr_bounds (p) +#else +# define ptr_bounds_init(p) (p) +#endif + +/* Return a copy of P, but with bounds [P, P + N). + This is a loophole in pointer bounds checking. */ +#ifdef __CHKP__ +# define ptr_bounds_set(p, n) __builtin___bnd_set_ptr_bounds (p, n) +#else +# define ptr_bounds_set(p, n) ((void) (size_t) {n}, p) +#endif + +INLINE_HEADER_END + +#endif /* PTR_BOUNDS_H */ diff --git a/src/regex.c b/src/regex.c index d70a59cbb85..2185fc97d3b 100644 --- a/src/regex.c +++ b/src/regex.c @@ -519,13 +519,7 @@ ptrdiff_t emacs_re_safe_alloca = MAX_ALLOCA; #endif /* Type of source-pattern and string chars. */ -#ifdef _MSC_VER -typedef unsigned char re_char; -typedef const re_char const_re_char; -#else typedef const unsigned char re_char; -typedef re_char const_re_char; -#endif typedef char boolean; @@ -2403,7 +2397,7 @@ do { \ } while (0) static reg_errcode_t -regex_compile (const_re_char *pattern, size_t size, +regex_compile (re_char *pattern, size_t size, #ifdef emacs # define syntax RE_SYNTAX_EMACS bool posix_backtracking, @@ -3728,7 +3722,7 @@ insert_op2 (re_opcode_t op, unsigned char *loc, int arg1, int arg2, unsigned cha least one character before the ^. */ static boolean -at_begline_loc_p (const_re_char *pattern, const_re_char *p, reg_syntax_t syntax) +at_begline_loc_p (re_char *pattern, re_char *p, reg_syntax_t syntax) { re_char *prev = p - 2; boolean odd_backslashes; @@ -3769,7 +3763,7 @@ at_begline_loc_p (const_re_char *pattern, const_re_char *p, reg_syntax_t syntax) at least one character after the $, i.e., `P < PEND'. */ static boolean -at_endline_loc_p (const_re_char *p, const_re_char *pend, reg_syntax_t syntax) +at_endline_loc_p (re_char *p, re_char *pend, reg_syntax_t syntax) { re_char *next = p; boolean next_backslash = *next == '\\'; @@ -3813,7 +3807,7 @@ group_in_compile_stack (compile_stack_type compile_stack, regnum_t regnum) Return -1 if fastmap was not updated accurately. */ static int -analyze_first (const_re_char *p, const_re_char *pend, char *fastmap, +analyze_first (re_char *p, re_char *pend, char *fastmap, const int multibyte) { int j, k; @@ -4555,7 +4549,7 @@ static int bcmp_translate (re_char *s1, re_char *s2, /* If the operation is a match against one or more chars, return a pointer to the next operation, else return NULL. */ static re_char * -skip_one_char (const_re_char *p) +skip_one_char (re_char *p) { switch (*p++) { @@ -4597,7 +4591,7 @@ skip_one_char (const_re_char *p) /* Jump over non-matching operations. */ static re_char * -skip_noops (const_re_char *p, const_re_char *pend) +skip_noops (re_char *p, re_char *pend) { int mcnt; while (p < pend) @@ -4628,7 +4622,7 @@ skip_noops (const_re_char *p, const_re_char *pend) character (i.e. without any translations). UNIBYTE denotes whether c is unibyte or multibyte character. */ static bool -execute_charset (const_re_char **pp, unsigned c, unsigned corig, bool unibyte) +execute_charset (re_char **pp, unsigned c, unsigned corig, bool unibyte) { re_char *p = *pp, *rtp = NULL; bool not = (re_opcode_t) *p == charset_not; @@ -4692,8 +4686,8 @@ execute_charset (const_re_char **pp, unsigned c, unsigned corig, bool unibyte) /* Non-zero if "p1 matches something" implies "p2 fails". */ static int -mutually_exclusive_p (struct re_pattern_buffer *bufp, const_re_char *p1, - const_re_char *p2) +mutually_exclusive_p (struct re_pattern_buffer *bufp, re_char *p1, + re_char *p2) { re_opcode_t op2; const boolean multibyte = RE_MULTIBYTE_P (bufp); @@ -4931,8 +4925,8 @@ WEAK_ALIAS (__re_match_2, re_match_2) /* This is a separate function so that we can force an alloca cleanup afterwards. */ static regoff_t -re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, - size_t size1, const_re_char *string2, size_t size2, +re_match_2_internal (struct re_pattern_buffer *bufp, re_char *string1, + size_t size1, re_char *string2, size_t size2, ssize_t pos, struct re_registers *regs, ssize_t stop) { /* General temporaries. */ @@ -6222,10 +6216,10 @@ re_match_2_internal (struct re_pattern_buffer *bufp, const_re_char *string1, bytes; nonzero otherwise. */ static int -bcmp_translate (const_re_char *s1, const_re_char *s2, register ssize_t len, +bcmp_translate (re_char *s1, re_char *s2, ssize_t len, RE_TRANSLATE_TYPE translate, const int target_multibyte) { - register re_char *p1 = s1, *p2 = s2; + re_char *p1 = s1, *p2 = s2; re_char *p1_end = s1 + len; re_char *p2_end = s2 + len; diff --git a/src/syntax.c b/src/syntax.c index 63866796188..a7977666593 100644 --- a/src/syntax.c +++ b/src/syntax.c @@ -605,6 +605,26 @@ find_defun_start (ptrdiff_t pos, ptrdiff_t pos_byte) && MODIFF == find_start_modiff) return find_start_value; + if (!NILP (Vcomment_use_syntax_ppss)) + { + EMACS_INT modiffs = CHARS_MODIFF; + Lisp_Object ppss = call1 (Qsyntax_ppss, make_number (pos)); + if (modiffs != CHARS_MODIFF) + error ("syntax-ppss modified the buffer!"); + TEMP_SET_PT_BOTH (opoint, opoint_byte); + Lisp_Object boc = Fnth (make_number (8), ppss); + if (NUMBERP (boc)) + { + find_start_value = XINT (boc); + find_start_value_byte = CHAR_TO_BYTE (find_start_value); + } + else + { + find_start_value = pos; + find_start_value_byte = pos_byte; + } + goto found; + } if (!open_paren_in_column_0_is_defun_start) { find_start_value = BEGV; @@ -874,6 +894,7 @@ back_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, case Sopen: /* Assume a defun-start point is outside of strings. */ if (open_paren_in_column_0_is_defun_start + && NILP (Vcomment_use_syntax_ppss) && (from == stop || (temp_byte = dec_bytepos (from_byte), FETCH_CHAR (temp_byte) == '\n'))) @@ -3689,6 +3710,11 @@ void syms_of_syntax (void) { DEFSYM (Qsyntax_table_p, "syntax-table-p"); + DEFSYM (Qsyntax_ppss, "syntax-ppss"); + DEFVAR_LISP ("comment-use-syntax-ppss", + Vcomment_use_syntax_ppss, + doc: /* Non-nil means `forward-comment' can use `syntax-ppss' internally. */); + Vcomment_use_syntax_ppss = Qt; staticpro (&Vsyntax_code_object); diff --git a/src/sysdep.c b/src/sysdep.c index 34bff23386d..bc34d8dc059 100644 --- a/src/sysdep.c +++ b/src/sysdep.c @@ -1671,7 +1671,7 @@ emacs_sigaction_init (struct sigaction *action, signal_handler_t handler) } #ifdef FORWARD_SIGNAL_TO_MAIN_THREAD -pthread_t main_thread_id; +static pthread_t main_thread_id; #endif /* SIG has arrived at the current process. Deliver it to the main diff --git a/src/syssignal.h b/src/syssignal.h index 4f6da845ad1..0887eacb05d 100644 --- a/src/syssignal.h +++ b/src/syssignal.h @@ -32,7 +32,6 @@ extern void unblock_tty_out_signal (sigset_t const *); #ifdef HAVE_PTHREAD #include <pthread.h> -extern pthread_t main_thread_id; /* If defined, asynchronous signals delivered to a non-main thread are forwarded to the main thread. */ #define FORWARD_SIGNAL_TO_MAIN_THREAD diff --git a/src/w32fns.c b/src/w32fns.c index e50b7d5c3c3..ed375cddbef 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -9343,6 +9343,17 @@ If the underlying system call fails, value is nil. */) filename = Fexpand_file_name (filename, Qnil); encoded = ENCODE_FILE (filename); + /* If the file name has special constructs in it, + call the corresponding file handler. */ + Lisp_Object handler = Ffind_file_name_handler (encoded, Qfile_system_info); + if (!NILP (handler)) + { + value = call2 (handler, Qfile_system_info, encoded); + if (CONSP (value) || NILP (value)) + return value; + error ("Invalid handler in `file-name-handler-alist'"); + } + value = Qnil; /* Determining the required information on Windows turns out, sadly, @@ -10413,6 +10424,7 @@ syms_of_w32fns (void) DEFSYM (Qserif, "serif"); DEFSYM (Qzlib, "zlib"); DEFSYM (Qlcms2, "lcms2"); + DEFSYM (Qjson, "json"); Fput (Qundefined_color, Qerror_conditions, listn (CONSTYPE_PURE, 2, Qundefined_color, Qerror)); diff --git a/src/xdisp.c b/src/xdisp.c index 903815c6581..59fa00e1af4 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -12323,7 +12323,7 @@ build_desired_tool_bar_string (struct frame *f) /* Reuse f->desired_tool_bar_string, if possible. */ if (size < size_needed || NILP (f->desired_tool_bar_string)) fset_desired_tool_bar_string - (f, Fmake_string (make_number (size_needed), make_number (' '))); + (f, Fmake_string (make_number (size_needed), make_number (' '), Qnil)); else { AUTO_LIST4 (props, Qdisplay, Qnil, Qmenu_item, Qnil); @@ -23896,7 +23896,8 @@ store_mode_line_string (const char *string, Lisp_Object lisp_string, if (field_width > len) { field_width -= len; - lisp_string = Fmake_string (make_number (field_width), make_number (' ')); + lisp_string = Fmake_string (make_number (field_width), make_number (' '), + Qnil); if (!NILP (props)) Fadd_text_properties (make_number (0), make_number (field_width), props, lisp_string); @@ -31909,7 +31910,7 @@ x_draw_bottom_divider (struct window *w) int x1 = WINDOW_RIGHT_EDGE_X (w); int y0 = WINDOW_BOTTOM_EDGE_Y (w) - WINDOW_BOTTOM_DIVIDER_WIDTH (w); int y1 = WINDOW_BOTTOM_EDGE_Y (w); - struct window *p = !NILP (w->parent) ? XWINDOW (w->parent) : false; + struct window *p = !NILP (w->parent) ? XWINDOW (w->parent) : NULL; /* If W is vertically combined and has a sibling below, don't draw over any right divider. */ diff --git a/src/xfaces.c b/src/xfaces.c index f1fc6bb632f..34797994c3c 100644 --- a/src/xfaces.c +++ b/src/xfaces.c @@ -4487,6 +4487,7 @@ lookup_basic_face (struct frame *f, int face_id) case MOUSE_FACE_ID: name = Qmouse; break; case MENU_FACE_ID: name = Qmenu; break; case WINDOW_DIVIDER_FACE_ID: name = Qwindow_divider; break; + case VERTICAL_BORDER_FACE_ID: name = Qvertical_border; break; case WINDOW_DIVIDER_FIRST_PIXEL_FACE_ID: name = Qwindow_divider_first_pixel; break; case WINDOW_DIVIDER_LAST_PIXEL_FACE_ID: name = Qwindow_divider_last_pixel; break; case INTERNAL_BORDER_FACE_ID: name = Qinternal_border; break; diff --git a/src/xfns.c b/src/xfns.c index dd3b36c1330..12b7d83c383 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -215,8 +215,9 @@ x_real_pos_and_offsets (struct frame *f, int win_x = 0, win_y = 0, outer_x = 0, outer_y = 0; int real_x = 0, real_y = 0; bool had_errors = false; - Window win = (FRAME_PARENT_FRAME (f) - ? FRAME_X_WINDOW (FRAME_PARENT_FRAME (f)) + struct frame *parent_frame = FRAME_PARENT_FRAME (f); + Window win = (parent_frame + ? FRAME_X_WINDOW (parent_frame) : f->output_data.x->parent_desc); struct x_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); long max_len = 400; @@ -355,8 +356,8 @@ x_real_pos_and_offsets (struct frame *f, outer_geom_cookie = xcb_get_geometry (xcb_conn, FRAME_OUTER_WINDOW (f)); - if ((dpyinfo->root_window == f->output_data.x->parent_desc) - && !FRAME_PARENT_FRAME (f)) + if (!parent_frame + && dpyinfo->root_window == f->output_data.x->parent_desc) /* Try _NET_FRAME_EXTENTS if our parent is the root window. */ prop_cookie = xcb_get_property (xcb_conn, 0, win, dpyinfo->Xatom_net_frame_extents, @@ -470,8 +471,7 @@ x_real_pos_and_offsets (struct frame *f, #endif } - if ((dpyinfo->root_window == f->output_data.x->parent_desc) - && !FRAME_PARENT_FRAME (f)) + if (!parent_frame && dpyinfo->root_window == f->output_data.x->parent_desc) { /* Try _NET_FRAME_EXTENTS if our parent is the root window. */ #ifdef USE_XCB diff --git a/src/xml.c b/src/xml.c index 8bf5a3d122b..42059d77131 100644 --- a/src/xml.c +++ b/src/xml.c @@ -18,15 +18,15 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <config.h> +#include "lisp.h" +#include "buffer.h" + #ifdef HAVE_LIBXML2 #include <libxml/tree.h> #include <libxml/parser.h> #include <libxml/HTMLparser.h> -#include "lisp.h" -#include "buffer.h" - #ifdef WINDOWSNT @@ -291,16 +291,43 @@ If DISCARD-COMMENTS is non-nil, all HTML comments are discarded. */) return parse_region (start, end, base_url, discard_comments, false); return Qnil; } +#endif /* HAVE_LIBXML2 */ + +DEFUN ("libxml-available-p", Flibxml_available_p, Slibxml_available_p, 0, 0, 0, + doc: /* Return t if libxml2 support is available in this instance of Emacs.*/) + (void) +{ +#ifdef HAVE_LIBXML2 +# ifdef WINDOWSNT + Lisp_Object found = Fassq (Qlibxml2, Vlibrary_cache); + if (CONSP (found)) + return XCDR (found); + else + { + Lisp_Object status; + status = init_libxml2_functions () ? Qt : Qnil; + Vlibrary_cache = Fcons (Fcons (Qlibxml2, status), Vlibrary_cache); + return status; + } +# else + return Qt; +# endif /* WINDOWSNT */ +#else + return Qnil; +#endif /* HAVE_LIBXML2 */ +} + /*********************************************************************** Initialization ***********************************************************************/ void syms_of_xml (void) { +#ifdef HAVE_LIBXML2 defsubr (&Slibxml_parse_html_region); defsubr (&Slibxml_parse_xml_region); +#endif + defsubr (&Slibxml_available_p); } - -#endif /* HAVE_LIBXML2 */ diff --git a/src/xwidget.c b/src/xwidget.c index e095b0be56f..17f7d477f62 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -392,8 +392,7 @@ webkit_javascript_finished_cb (GObject *webview, /* FIXME: This might lead to disaster if LISP_CALLBACK’s object was garbage collected before now. See the FIXME in Fxwidget_webkit_execute_script. */ - store_xwidget_js_callback_event (xw, XIL ((intptr_t) lisp_callback), - lisp_value); + store_xwidget_js_callback_event (xw, XPL (lisp_callback), lisp_value); } @@ -585,22 +584,20 @@ x_draw_xwidget_glyph_string (struct glyph_string *s) xwidget on screen. Moving and clipping is done here. Also view initialization. */ struct xwidget *xww = s->xwidget; - struct xwidget_view *xv; + struct xwidget_view *xv = xwidget_view_lookup (xww, s->w); int clip_right; int clip_bottom; int clip_top; int clip_left; - /* FIXME: The result of this call is discarded. - What if the lookup fails? */ - xwidget_view_lookup (xww, s->w); - int x = s->x; int y = s->y + (s->height / 2) - (xww->height / 2); /* Do initialization here in the display loop because there is no - other time to know things like window placement etc. */ - xv = xwidget_init_view (xww, s, x, y); + other time to know things like window placement etc. Do not + create a new view if we have found one that is usable. */ + if (!xv) + xv = xwidget_init_view (xww, s, x, y); int text_area_x, text_area_y, text_area_width, text_area_height; @@ -725,7 +722,7 @@ argument procedure FUN.*/) /* FIXME: This hack might lead to disaster if FUN is garbage collected before store_xwidget_js_callback_event makes it visible to Lisp again. See the FIXME in webkit_javascript_finished_cb. */ - gpointer callback_arg = (gpointer) (intptr_t) XLI (fun); + gpointer callback_arg = XLP (fun); /* JavaScript execution happens asynchronously. If an elisp callback function is provided we pass it to the C callback diff --git a/test/Makefile.in b/test/Makefile.in index 7bc99fb5cb8..ed6cc42d889 100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@ -147,6 +147,12 @@ endif ## Save logs, and show logs for failed tests. WRITE_LOG = > $@ 2>&1 || { STAT=$$?; cat $@; exit $$STAT; } +ifdef EMACS_HYDRA_CI +## On Hydra, always show logs for certain problematic tests. +lisp/emacs-lisp/eieio-tests/eieio-tests.log \ +lisp/net/tramp-tests.log \ +: WRITE_LOG = 2>&1 | tee $@ +endif ifeq ($(TEST_LOAD_EL), yes) testloadfile = $*.el diff --git a/test/data/xdg/mimeapps.list b/test/data/xdg/mimeapps.list new file mode 100644 index 00000000000..27fbd94b16b --- /dev/null +++ b/test/data/xdg/mimeapps.list @@ -0,0 +1,9 @@ +[Default Applications] +x-test/foo=a.desktop + +[Added Associations] +x-test/foo=b.desktop +x-test/baz=a.desktop + +[Removed Associations] +x-test/foo=c.desktop;d.desktop diff --git a/test/data/xdg/mimeinfo.cache b/test/data/xdg/mimeinfo.cache new file mode 100644 index 00000000000..6e54f604fa0 --- /dev/null +++ b/test/data/xdg/mimeinfo.cache @@ -0,0 +1,4 @@ +[MIME Cache] +x-test/foo=c.desktop;d.desktop +x-test/bar=a.desktop;c.desktop +x-test/baz=b.desktop;d.desktop diff --git a/test/lisp/auth-source-pass-tests.el b/test/lisp/auth-source-pass-tests.el index 0e441ac01b1..86f59e51664 100644 --- a/test/lisp/auth-source-pass-tests.el +++ b/test/lisp/auth-source-pass-tests.el @@ -128,6 +128,11 @@ This function is intended to be set to `auth-source-debug`." (should (equal (auth-source-pass--find-match "foo.bar.com" nil) nil)))) +(ert-deftest auth-source-pass-find-match-matching-extracting-user-from-host () + (auth-source-pass--with-store '(("foo.com/bar")) + (should (equal (auth-source-pass--find-match "https://bar@foo.com" nil) + "foo.com/bar")))) + (ert-deftest auth-source-pass-search-with-user-first () (auth-source-pass--with-store '(("foo") ("user@foo")) (should (equal (auth-source-pass--find-match "foo" "user") diff --git a/test/lisp/char-fold-tests.el b/test/lisp/char-fold-tests.el index eb8dec74d65..364975317f2 100644 --- a/test/lisp/char-fold-tests.el +++ b/test/lisp/char-fold-tests.el @@ -117,16 +117,14 @@ (char-fold-to-regexp string))) (with-temp-buffer (save-excursion (insert string)) - (let ((time (time-to-seconds (current-time)))) + (let ((time (time-to-seconds))) ;; Our initial implementation of case-folding in char-folding ;; created a lot of redundant paths in the regexp. Because of ;; that, if a really long string "almost" matches, the regexp ;; engine took a long time to realize that it doesn't match. (should-not (char-fold-search-forward (concat string "c") nil 'noerror)) ;; Ensure it took less than a second. - (should (< (- (time-to-seconds (current-time)) - time) - 1)))))) + (should (< (- (time-to-seconds) time) 1)))))) (provide 'char-fold-tests) ;;; char-fold-tests.el ends here diff --git a/test/lisp/dired-aux-tests.el b/test/lisp/dired-aux-tests.el index f7935cd38b9..89cb7b6111d 100644 --- a/test/lisp/dired-aux-tests.el +++ b/test/lisp/dired-aux-tests.el @@ -20,7 +20,7 @@ ;;; Code: (require 'ert) (require 'dired-aux) - +(eval-when-compile (require 'cl-lib)) (ert-deftest dired-test-bug27496 () "Test for https://debbugs.gnu.org/27496 ." @@ -40,5 +40,59 @@ (should-not (dired-do-shell-command "ls ? ./`?`" nil files))) (delete-file foo)))) +;; Auxiliar macro for `dired-test-bug28834': it binds +;; `dired-create-destination-dirs' to CREATE-DIRS and execute BODY. +;; If YES-OR-NO is non-nil, it binds `yes-or-no-p' to +;; to avoid the prompt. +(defmacro with-dired-bug28834-test (create-dirs yes-or-no &rest body) + (declare (debug (form symbolp body))) + (let ((foo (make-symbol "foo"))) + `(let* ((,foo (make-temp-file "foo" 'dir)) + (dired-create-destination-dirs ,create-dirs)) + (setq from (make-temp-file "from")) + (setq to-cp + (expand-file-name + "foo-cp" (file-name-as-directory (expand-file-name "bar" ,foo)))) + (setq to-mv + (expand-file-name + "foo-mv" (file-name-as-directory (expand-file-name "qux" ,foo)))) + (unwind-protect + (if ,yes-or-no + (cl-letf (((symbol-function 'yes-or-no-p) + (lambda (prompt) (eq ,yes-or-no 'yes)))) + ,@body) + ,@body) + ;; clean up + (delete-directory ,foo 'recursive) + (delete-file from))))) + +(ert-deftest dired-test-bug28834 () + "test for https://debbugs.gnu.org/28834 ." + (let (from to-cp to-mv) + ;; `dired-create-destination-dirs' set to 'always. + (with-dired-bug28834-test + 'always nil + (dired-copy-file-recursive from to-cp nil) + (should (file-exists-p to-cp)) + (dired-rename-file from to-mv nil) + (should (file-exists-p to-mv))) + ;; `dired-create-destination-dirs' set to nil. + (with-dired-bug28834-test + nil nil + (should-error (dired-copy-file-recursive from to-cp nil)) + (should-error (dired-rename-file from to-mv nil))) + ;; `dired-create-destination-dirs' set to 'ask. + (with-dired-bug28834-test + 'ask 'yes ; Answer `yes' + (dired-copy-file-recursive from to-cp nil) + (should (file-exists-p to-cp)) + (dired-rename-file from to-mv nil) + (should (file-exists-p to-mv))) + (with-dired-bug28834-test + 'ask 'no ; Answer `no' + (should-error (dired-copy-file-recursive from to-cp nil)) + (should-error (dired-rename-file from to-mv nil))))) + + (provide 'dired-aux-tests) ;; dired-aux-tests.el ends here diff --git a/test/lisp/electric-tests.el b/test/lisp/electric-tests.el index 8a13c8c7b2c..60191bfbbaa 100644 --- a/test/lisp/electric-tests.el +++ b/test/lisp/electric-tests.el @@ -617,6 +617,12 @@ baz\"\"" :fixture-fn #'electric-quote-local-mode :test-in-comments nil :test-in-strings nil) +(define-electric-pair-test electric-quote-replace-double-disabled + "" "\"" :expected-string "\"" :expected-point 2 + :modes '(text-mode) + :fixture-fn #'electric-quote-local-mode + :test-in-comments nil :test-in-strings nil) + (define-electric-pair-test electric-quote-context-sensitive-backtick "" "`" :expected-string "`" :expected-point 2 :modes '(text-mode) @@ -638,6 +644,13 @@ baz\"\"" :bindings '((electric-quote-context-sensitive . t)) :test-in-comments nil :test-in-strings nil) +(define-electric-pair-test electric-quote-replace-double-bob + "" "\"" :expected-string "“" :expected-point 2 + :modes '(text-mode) + :fixture-fn #'electric-quote-local-mode + :bindings '((electric-quote-replace-double . t)) + :test-in-comments nil :test-in-strings nil) + (define-electric-pair-test electric-quote-context-sensitive-bol-single "a\n" "--'" :expected-string "a\n‘" :expected-point 4 :modes '(text-mode) @@ -652,6 +665,13 @@ baz\"\"" :bindings '((electric-quote-context-sensitive . t)) :test-in-comments nil :test-in-strings nil) +(define-electric-pair-test electric-quote-replace-double-bol + "a\n" "--\"" :expected-string "a\n“" :expected-point 4 + :modes '(text-mode) + :fixture-fn #'electric-quote-local-mode + :bindings '((electric-quote-replace-double . t)) + :test-in-comments nil :test-in-strings nil) + (define-electric-pair-test electric-quote-context-sensitive-after-space-single " " "-'" :expected-string " ‘" :expected-point 3 :modes '(text-mode) @@ -666,6 +686,13 @@ baz\"\"" :bindings '((electric-quote-context-sensitive . t)) :test-in-comments nil :test-in-strings nil) +(define-electric-pair-test electric-quote-replace-double-after-space + " " "-\"" :expected-string " “" :expected-point 3 + :modes '(text-mode) + :fixture-fn #'electric-quote-local-mode + :bindings '((electric-quote-replace-double . t)) + :test-in-comments nil :test-in-strings nil) + (define-electric-pair-test electric-quote-context-sensitive-after-letter-single "a" "-'" :expected-string "a’" :expected-point 3 :modes '(text-mode) @@ -680,6 +707,13 @@ baz\"\"" :bindings '((electric-quote-context-sensitive . t)) :test-in-comments nil :test-in-strings nil) +(define-electric-pair-test electric-quote-replace-double-after-letter + "a" "-\"" :expected-string "a”" :expected-point 3 + :modes '(text-mode) + :fixture-fn #'electric-quote-local-mode + :bindings '((electric-quote-replace-double . t)) + :test-in-comments nil :test-in-strings nil) + (define-electric-pair-test electric-quote-context-sensitive-after-paren-single "(" "-'" :expected-string "(‘" :expected-point 3 :modes '(text-mode) @@ -694,6 +728,38 @@ baz\"\"" :bindings '((electric-quote-context-sensitive . t)) :test-in-comments nil :test-in-strings nil) +(define-electric-pair-test electric-quote-replace-double-after-paren + "(" "-\"" :expected-string "(“" :expected-point 3 + :modes '(text-mode) + :fixture-fn #'electric-quote-local-mode + :bindings '((electric-quote-replace-double . t)) + :test-in-comments nil :test-in-strings nil) + +(define-electric-pair-test electric-quote-replace-double-no-context-single + " " "-'" :expected-string " ’" :expected-point 3 + :modes '(text-mode) + :fixture-fn #'electric-quote-local-mode + :bindings '((electric-quote-replace-double . t)) + :test-in-comments nil :test-in-strings nil) + +(define-electric-pair-test electric-quote-replace-double-escaped-open + "foo \\" "-----\"" :expected-string "foo \\“" + :expected-point 7 :modes '(emacs-lisp-mode c-mode) + :fixture-fn #'electric-quote-local-mode + :bindings '((electric-quote-replace-double . t) + (electric-quote-comment . t) + (electric-quote-string . t)) + :test-in-comments t :test-in-strings t :test-in-code nil) + +(define-electric-pair-test electric-quote-replace-double-escaped-close + "foo \\“foo\\" "----------\"" :expected-string "foo \\“foo\\”" + :expected-point 12 :modes '(emacs-lisp-mode c-mode) + :fixture-fn #'electric-quote-local-mode + :bindings '((electric-quote-replace-double . t) + (electric-quote-comment . t) + (electric-quote-string . t)) + :test-in-comments t :test-in-strings t :test-in-code nil) + ;; Simulate ‘markdown-mode’: it sets both ‘comment-start’ and ;; ‘comment-use-syntax’, but derives from ‘text-mode’. (define-electric-pair-test electric-quote-markdown-in-text diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index 13df5912eef..6ae7cdb9f9c 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -534,23 +534,17 @@ literals (Bug#20852)." (ert-deftest bytecomp-tests--old-style-backquotes () "Check that byte compiling warns about old-style backquotes." - (should (boundp 'lread--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-error-on-warn t) - (byte-compile-debug t) - (err (should-error (byte-compile-file source)))) - (should (equal (cdr err) - (list "!! The file uses old-style backquotes !! -This functionality has been obsolete for more than 10 years already -and will be removed soon. See (elisp)Backquote in the manual."))))))) + (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." - (should (boundp 'lread--old-style-backquotes)) (bytecomp-tests--with-temp-file source (dolist (form '((function-put 'bytecomp-tests--foo 'foo 1) (function-put 'bytecomp-tests--foo 'bar 2) diff --git a/test/lisp/emacs-lisp/cl-lib-tests.el b/test/lisp/emacs-lisp/cl-lib-tests.el index 26bc6188738..69d0a747105 100644 --- a/test/lisp/emacs-lisp/cl-lib-tests.el +++ b/test/lisp/emacs-lisp/cl-lib-tests.el @@ -201,6 +201,10 @@ :b :a :a 42) '(42 :a)))) +(ert-deftest cl-lib-empty-keyargs () + (should-error (funcall (cl-function (lambda (&key) 1)) + :b 1))) + (cl-defstruct (mystruct (:constructor cl-lib--con-1 (&aux (abc 1))) (:constructor cl-lib--con-2 (&optional def) "Constructor docstring.")) @@ -512,6 +516,16 @@ (ert-deftest cl-lib-symbol-macrolet-2 () (should (equal (cl-lib-symbol-macrolet-4+5) (+ 4 5)))) + +(ert-deftest cl-lib-symbol-macrolet-hide () + ;; bug#26325 + (should (equal (let ((y 5)) + (cl-symbol-macrolet ((x y)) + (list x + (let ((x 6)) (list x y)) + (cl-letf ((x 6)) (list x y))))) + '(5 (6 5) (6 6))))) + (defun cl-lib-tests--dummy-function () ;; Dummy function to see if the file is compiled. t) diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index f0bde7af397..edb1530cad5 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -497,4 +497,12 @@ collection clause." vconcat (vector (1+ x))) [2 3 4 5 6]))) + +(ert-deftest cl-macs-loop-for-as-equals-and () + "Test for https://debbugs.gnu.org/29799 ." + (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) + collect (list k x)))))) + ;;; cl-macs-tests.el ends here diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el index ee739740ae7..4657321506b 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el @@ -887,15 +887,33 @@ Subclasses to override slot attributes.") (should (= (length (eieio-build-class-alist 'opt-test1 nil)) 2)) (should (= (length (eieio-build-class-alist 'opt-test1 t)) 1))) +(mapatoms (lambda (a) + (when (and (fboundp a) + (string-match "\\`cl--?generic" + (symbol-name a))) + (trace-function-background a)))) + (defclass eieio--testing () ()) (defmethod constructor :static ((_x eieio--testing) newname &rest _args) (list newname 2)) +(defun eieio-test-dump-trace () + (message "%s" (with-current-buffer "*trace-output*" + (goto-char (point-min)) + (while (re-search-forward "[\0-\010\013-\037]" nil t) + (insert (prog1 (format "\\%03o" (char-before)) + (delete-char -1)))) + (buffer-string)))) +(eieio-test-dump-trace) + (ert-deftest eieio-test-37-obsolete-name-in-constructor () ;; FIXME repeated intermittent failures on hydra (bug#24503) - (skip-unless (not (getenv "EMACS_HYDRA_CI"))) - (should (equal (eieio--testing "toto") '("toto" 2)))) + (with-current-buffer "*trace-output*" + (erase-buffer)) + (unwind-protect + (should (equal (eieio--testing "toto") '("toto" 2))) + (eieio-test-dump-trace))) (ert-deftest eieio-autoload () "Tests to see whether reftex-auc has been autoloaded" diff --git a/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el b/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el new file mode 100644 index 00000000000..7d1a128694c --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el @@ -0,0 +1,76 @@ +;;; faceup-test-mode.el --- Dummy major mode for testing `faceup'. + +;; Copyright (C) 2014-2018 Free Software Foundation, Inc. + +;; Author: Anders Lindgren +;; Keywords: languages, faces + +;; 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: + +;; Dummy major-mode for testing `faceup', a regression test system for +;; font-lock keywords (syntax highlighting rules for Emacs). +;; +;; This mode use `syntax-propertize' to set the `syntax-table' +;; property on "<" and ">" in "<TEXT>" to make them act like +;; parentheses. +;; +;; This mode also sets the `help-echo' property on the text WARNING, +;; the effect is that Emacs displays a tooltip when you move your +;; mouse on to the text. + +;;; Code: + +(defvar faceup-test-mode-syntax-table + (make-syntax-table) + "Syntax table for `faceup-test-mode'.") + +(defvar faceup-test-font-lock-keywords + '(("\\_<WARNING\\_>" + (0 (progn + (add-text-properties (match-beginning 0) + (match-end 0) + '(help-echo "Baloon tip: Fly smoothly!")) + font-lock-warning-face)))) + "Highlight rules for `faceup-test-mode'.") + +(defun faceup-test-syntax-propertize (start end) + (goto-char start) + (funcall + (syntax-propertize-rules + ("\\(<\\)\\([^<>\n]*\\)\\(>\\)" + (1 "() ") + (3 ")( "))) + start end)) + +(defmacro faceup-test-define-prog-mode (mode name &rest args) + "Define a major mode for a programming language. +If `prog-mode' is defined, inherit from it." + (declare (indent defun)) + `(define-derived-mode + ,mode ,(and (fboundp 'prog-mode) 'prog-mode) + ,name ,@args)) + +(faceup-test-define-prog-mode faceup-test-mode "faceup-test" + "Dummy major mode for testing `faceup', a test system for font-lock." + (set (make-local-variable 'syntax-propertize-function) + #'faceup-test-syntax-propertize) + (setq font-lock-defaults '(faceup-test-font-lock-keywords nil))) + +(provide 'faceup-test-mode) + +;;; faceup-test-mode.el ends here 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 new file mode 100644 index 00000000000..0558bd12e5f --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el @@ -0,0 +1,32 @@ +;;; faceup-test-this-file-directory.el --- Support file for faceup tests + +;; Copyright (C) 2014-2018 Free Software Foundation, Inc. + +;; Author: Anders Lindgren +;; Keywords: languages, faces + +;; 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: + +;; Support file for `faceup-test-basics.el'. This file is used to test +;; `faceup-this-file-directory' in various contexts. + +;;; Code: + +(defvar faceup-test-this-file-directory (faceup-this-file-directory)) + +;;; faceup-test-this-file-directory.el ends here diff --git a/test/lisp/emacs-lisp/faceup-resources/files/test1.txt b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt new file mode 100644 index 00000000000..d971f364c2d --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt @@ -0,0 +1,15 @@ +This is a test of `faceup', a regression test system for font-lock +keywords. It should use major mode `faceup-test-mode'. + +WARNING: The first word on this line should use +`font-lock-warning-face', and a tooltip should be displayed if the +mouse pointer is moved over it. + +In this mode "<" and ">" are parentheses, but only when on the same +line without any other "<" and ">" characters between them. +<OK> <NOT <OK> > +< +NOT OK +> + +test1.txt ends here. diff --git a/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup new file mode 100644 index 00000000000..7d4938adf17 --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-resources/files/test1.txt.faceup @@ -0,0 +1,15 @@ +This is a test of `faceup', a regression test system for font-lock +keywords. It should use major mode `faceup-test-mode'. + +«(help-echo):"Baloon tip: Fly smoothly!":«w:WARNING»»: The first word on this line should use +`font-lock-warning-face', and a tooltip should be displayed if the +mouse pointer is moved over it. + +In this mode «s:"«(syntax-table):(4 . 41):<»"» and «s:"«(syntax-table):(5 . 40):>»"» are parentheses, but only when on the same +line without any other «s:"«(syntax-table):(4 . 41):<»"» and «s:"«(syntax-table):(5 . 40):>»"» characters between them. +«(syntax-table):(4 . 41):<»OK«(syntax-table):(5 . 40):>» <NOT «(syntax-table):(4 . 41):<»OK«(syntax-table):(5 . 40):>» > +< +NOT OK +> + +test1.txt ends here. diff --git a/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el b/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el new file mode 100644 index 00000000000..f910a1d732a --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el @@ -0,0 +1,269 @@ +;;; faceup-test-basics.el --- Tests for the `faceup' package. + +;; Copyright (C) 2014-2018 Free Software Foundation, Inc. + +;; Author: Anders Lindgren +;; Keywords: languages, faces + +;; 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: + +;; Basic tests for the `faceup' package. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(require 'faceup) + +(ert-deftest faceup-functions () + "Test primitive functions." + (should (equal (faceup-normalize-face-property '()) '())) + (should (equal (faceup-normalize-face-property 'a) '(a))) + (should (equal (faceup-normalize-face-property '(a)) '(a))) + (should (equal (faceup-normalize-face-property '(:x t)) '((:x t)))) + (should (equal (faceup-normalize-face-property '(:x t a)) '((:x t)))) + (should (equal (faceup-normalize-face-property '(:x t a b)) '((:x t)))) + (should (equal (faceup-normalize-face-property '(a :x t)) '(a (:x t)))) + (should (equal (faceup-normalize-face-property '(a b :x t)) + '(a b (:x t)))) + + (should (equal (faceup-normalize-face-property '(:x t :y nil)) + '((:y nil) (:x t)))) + (should (equal (faceup-normalize-face-property '(:x t :y nil a)) + '((:y nil) (:x t)))) + (should (equal (faceup-normalize-face-property '(:x t :y nil a b)) + '((:y nil) (:x t)))) + (should (equal (faceup-normalize-face-property '(a :x t :y nil)) + '(a (:y nil) (:x t)))) + (should (equal (faceup-normalize-face-property '(a b :x t :y nil)) + '(a b (:y nil) (:x t))))) + + +(ert-deftest faceup-markup-basics () + (should (equal (faceup-markup-string "") "")) + (should (equal (faceup-markup-string "test") "test"))) + +(ert-deftest faceup-markup-escaping () + (should (equal (faceup-markup-string "«") "««")) + (should (equal (faceup-markup-string "«A«B«C«") "««A««B««C««")) + (should (equal (faceup-markup-string "»") "«»")) + (should (equal (faceup-markup-string "»A»B»C»") "«»A«»B«»C«»"))) + +(ert-deftest faceup-markup-plain () + ;; UU + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face underline))) + "AB«U:CD»EF"))) + +(ert-deftest faceup-markup-plain-full-text () + ;; UUUUUU + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" 0 6 (face underline))) + "«U:ABCDEF»"))) + +(ert-deftest faceup-markup-anonymous-face () + ;; AA + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face (:underline t)))) + "AB«:(:underline t):CD»EF"))) + +(ert-deftest faceup-markup-anonymous-face-2keys () + ;; AA + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face (:foo t :bar nil)))) + "AB«:(:foo t):«:(:bar nil):CD»»EF")) + ;; Plist in list. + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face ((:foo t :bar nil))))) + "AB«:(:foo t):«:(:bar nil):CD»»EF")) + ;; Two plists. + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face ((:foo t) (:bar nil))))) + "AB«:(:bar nil):«:(:foo t):CD»»EF"))) + +(ert-deftest faceup-markup-anonymous-nested () + ;; AA + ;; IIII + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" + 1 2 (face ((:foo t))) + 2 4 (face ((:bar t) (:foo t))) + 4 5 (face ((:foo t))))) + "A«:(:foo t):B«:(:bar t):CD»E»F"))) + +(ert-deftest faceup-markup-nested () + ;; UU + ;; IIII + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" + 1 2 (face italic) + 2 4 (face (underline italic)) + 4 5 (face italic))) + "A«I:B«U:CD»E»F"))) + +(ert-deftest faceup-markup-overlapping () + ;; UUU + ;; III + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" + 1 2 (face italic) + 2 4 (face (underline italic)) + 4 5 (face underline))) + "A«I:B«U:CD»»«U:E»F")) + ;; III + ;; UUU + ;; ABCDEF + (should (equal (faceup-markup-string + #("ABCDEF" + 1 2 (face italic) + 2 4 (face (italic underline)) + 4 5 (face underline))) + "A«I:B»«U:«I:CD»E»F"))) + +(ert-deftest faceup-markup-multi-face () + ;; More than one face at the same location. + ;; + ;; The property to the front takes precedence, it is rendered as the + ;; innermost parenthesis pair. + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face (underline italic)))) + "AB«I:«U:CD»»EF")) + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (face (italic underline)))) + "AB«U:«I:CD»»EF")) + ;; Equal ranges, full text. + (should (equal (faceup-markup-string + #("ABCDEF" 0 6 (face (underline italic)))) + "«I:«U:ABCDEF»»")) + ;; Ditto, with stray markup characters. + (should (equal (faceup-markup-string + #("AB«CD»EF" 0 8 (face (underline italic)))) + "«I:«U:AB««CD«»EF»»"))) + +(ert-deftest faceup-markup-multi-property () + (let ((faceup-properties '(alpha beta gamma))) + ;; One property. + (should (equal (faceup-markup-string + #("ABCDEF" 2 4 (alpha (a l p h a)))) + "AB«(alpha):(a l p h a):CD»EF")) + + ;; Two properties, inner enclosed. + (should (equal (faceup-markup-string + (let ((s (copy-sequence "ABCDEFGHIJ"))) + (set-text-properties 2 8 '(alpha (a l p h a)) s) + (font-lock-append-text-property 4 6 'beta '(b e t a) s) + s)) + "AB«(alpha):(a l p h a):CD«(beta):(b e t a):EF»GH»IJ")) + + ;; Two properties, same end + (should (equal (faceup-markup-string + (let ((s (copy-sequence "ABCDEFGH"))) + (set-text-properties 2 6 '(alpha (a)) s) + (add-text-properties 4 6 '(beta (b)) s) + s)) + "AB«(alpha):(a):CD«(beta):(b):EF»»GH")) + + ;; Two properties, overlap. + (should (equal (faceup-markup-string + (let ((s (copy-sequence "ABCDEFGHIJ"))) + (set-text-properties 2 6 '(alpha (a)) s) + (add-text-properties 4 8 '(beta (b)) s) + s)) + "AB«(alpha):(a):CD«(beta):(b):EF»»«(beta):(b):GH»IJ")))) + + +(ert-deftest faceup-clean () + "Test the clean features of `faceup'." + (should (equal (faceup-clean-string "") "")) + (should (equal (faceup-clean-string "test") "test")) + (should (equal (faceup-clean-string "AB«U:CD»EF") "ABCDEF")) + (should (equal (faceup-clean-string "«U:ABCDEF»") "ABCDEF")) + (should (equal (faceup-clean-string "A«I:B«U:CD»E»F") "ABCDEF")) + (should (equal (faceup-clean-string "A«I:B«U:CD»»«U:E»F") "ABCDEF")) + (should (equal (faceup-clean-string "AB«I:«U:CD»»EF") "ABCDEF")) + (should (equal (faceup-clean-string "«I:«U:ABCDEF»»") "ABCDEF")) + (should (equal (faceup-clean-string "«(foo)I:ABC»DEF") "ABCDEF")) + (should (equal (faceup-clean-string "«:(:foo t):ABC»DEF") "ABCDEF")) + ;; Escaped markup characters. + (should (equal (faceup-clean-string "««") "«")) + (should (equal (faceup-clean-string "«»") "»")) + (should (equal (faceup-clean-string "A«I:B«U:CD»«»»«U:E»F") "ABCD»EF"))) + + +(ert-deftest faceup-render () + "Test the render features of `faceup'." + (should (equal (faceup-render-string "") "")) + (should (equal (faceup-render-string "««") "«")) + (should (equal (faceup-render-string "«»") "»")) + (should (equal (faceup-render-string "A«I:B«U:CD»«»»«U:E»F") "ABCD»EF"))) + + +(defvar faceup-test-resources-directory + (concat (file-name-directory + (substring (faceup-this-file-directory) 0 -1)) + "faceup-resources/") + "The `faceup-resources' directory.") + + +(defvar faceup-test-this-file-directory nil + "The result of `faceup-this-file-directory' in various contexts. + +This is set by the file test support file +`faceup-test-this-file-directory.el'.") + + +(ert-deftest faceup-directory () + "Test `faceup-this-file-directory'." + (let ((file (concat faceup-test-resources-directory + "faceup-test-this-file-directory.el")) + (load-file-name nil)) + ;; Test normal load. + (makunbound 'faceup-test-this-file-directory) + (load file nil :nomessage) + (should (equal faceup-test-this-file-directory + faceup-test-resources-directory)) + ;; Test `eval-buffer'. + (makunbound 'faceup-test-this-file-directory) + (save-excursion + (find-file file) + (eval-buffer)) + (should (equal faceup-test-this-file-directory + faceup-test-resources-directory)) + ;; Test `eval-defun'. + (makunbound 'faceup-test-this-file-directory) + (save-excursion + (find-file file) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + ;; Note: In batch mode, this prints the result of the + ;; evaluation. Unfortunately, this is hard to fix. + (eval-defun nil) + (forward-sexp)))) + (should (equal faceup-test-this-file-directory + faceup-test-resources-directory)))) + +(provide 'faceup-test-basics) + +;;; faceup-test-basics.el ends here diff --git a/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el b/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el new file mode 100644 index 00000000000..8df38bcc8a9 --- /dev/null +++ b/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el @@ -0,0 +1,63 @@ +;;; faceup-test-files.el --- Self test of `faceup' using dummy major mode. + +;; Copyright (C) 2014-2018 Free Software Foundation, Inc. + +;; Author: Anders Lindgren +;; Keywords: languages, faces + +;; 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: + +;; Self test of `faceup' with a major mode that sets both the +;; `syntax-table' and the `echo-help' property. +;; +;; This file can also be seen as a blueprint of test cases for real +;; major modes. + +;;; Code: + +(require 'faceup) + +;; Note: The byte compiler needs the value to load `faceup-test-mode', +;; hence the `eval-and-compile'. +(eval-and-compile + (defvar faceup-test-files-dir (faceup-this-file-directory) + "The directory of this file.")) + +(require 'faceup-test-mode + (concat faceup-test-files-dir + "../faceup-resources/" + "faceup-test-mode.el")) + +(defun faceup-test-files-check-one (file) + "Test that FILE is fontified as the .faceup file describes. + +FILE is interpreted as relative to this source directory." + (let ((faceup-properties '(face syntax-table help-echo))) + (faceup-test-font-lock-file 'faceup-test-mode + (concat + faceup-test-files-dir + "../faceup-resources/" + file)))) +(faceup-defexplainer faceup-test-files-check-one) + +(ert-deftest faceup-files () + (should (faceup-test-files-check-one "files/test1.txt"))) + +(provide 'faceup-test-files) + +;;; faceup-test-files.el ends here diff --git a/test/lisp/emacs-lisp/testcover-resources/testcases.el b/test/lisp/emacs-lisp/testcover-resources/testcases.el index cacdef9cb42..c9703b03de0 100644 --- a/test/lisp/emacs-lisp/testcover-resources/testcases.el +++ b/test/lisp/emacs-lisp/testcover-resources/testcases.el @@ -53,7 +53,6 @@ ;; ==== constants-bug-25316 ==== "Testcover doesn't splotch constants." -:expected-result :failed ;; ==== (defconst testcover-testcase-const "apples") (defun testcover-testcase-zero () 0) @@ -76,7 +75,6 @@ ;; ==== customize-defcustom-bug-25326 ==== "Testcover doesn't prevent testing of defcustom values." -:expected-result :failed ;; ==== (defgroup testcover-testcase nil "Test case for testcover" @@ -135,7 +133,6 @@ ;; ==== 1-value-symbol-bug-25316 ==== "Wrapping a form with 1value prevents splotching." -:expected-result :failed ;; ==== (defun testcover-testcase-always-zero (num) (- num%%% num%%%)%%%) @@ -230,7 +227,6 @@ ;; ==== quotes-within-backquotes-bug-25316 ==== "Forms to instrument are found within quotes within backquotes." -:expected-result :failed ;; ==== (defun testcover-testcase-make-list () (list 'defun 'defvar)) @@ -296,7 +292,6 @@ ;; ==== backquote-1value-bug-24509 ==== "Commas within backquotes are recognized as non-1value." -:expected-result :failed ;; ==== (defmacro testcover-testcase-lambda (&rest body) `(lambda () ,@body)) @@ -320,7 +315,6 @@ ;; ==== pcase-bug-24688 ==== "Testcover copes with condition-case within backquoted list." -:expected-result :failed ;; ==== (defun testcover-testcase-pcase (form) (pcase form%%% @@ -335,7 +329,6 @@ ;; ==== defun-in-backquote-bug-11307-and-24743 ==== "Testcover handles defun forms within backquoted list." -:expected-result :failed ;; ==== (defmacro testcover-testcase-defun (name &rest body) (declare (debug (symbolp def-body))) @@ -348,7 +341,6 @@ ;; ==== closure-1value-bug ==== "Testcover does not mark closures as 1value." -:expected-result :failed ;; ==== ;; -*- lexical-binding:t -*- (setq testcover-testcase-foo nil) @@ -365,7 +357,6 @@ ;; ==== by-value-vs-by-reference-bug-25351 ==== "An object created by a 1value expression may be modified by other code." -:expected-result :failed ;; ==== (defun testcover-testcase-ab () (list 'a 'b)) @@ -396,9 +387,16 @@ (should (equal '(a b c) (testcover-testcase-dotted-bq nil '(d e)))) (should (equal '(a b c d e) (testcover-testcase-dotted-bq t '(d e)))) +;; ==== quoted-backquote ==== +"Testcover correctly instruments the quoted backquote symbol." +;; ==== +(defun testcover-testcase-special-symbols () + (list '\` '\, '\,@)) + +(should (equal '(\` \, \,@) (testcover-testcase-special-symbols))) + ;; ==== backquoted-vector-bug-25316 ==== "Testcover reinstruments within backquoted vectors." -:expected-result :failed ;; ==== (defun testcover-testcase-vec (a b c) `[,a%%% ,(list b%%% c%%%)%%%]%%%) @@ -415,7 +413,6 @@ ;; ==== vector-in-macro-spec-bug-25316 ==== "Testcover reinstruments within vectors." -:expected-result :failed ;; ==== (defmacro testcover-testcase-nth-case (arg vec) (declare (indent 1) @@ -435,7 +432,6 @@ ;; ==== mapcar-is-not-compose ==== "Mapcar with 1value arguments is not 1value." -:expected-result :failed ;; ==== (defvar testcover-testcase-num 0) (defun testcover-testcase-add-num (n) @@ -450,10 +446,10 @@ ;; ==== function-with-edebug-spec-bug-25316 ==== "Functions can have edebug specs too. -See c-make-font-lock-search-function for an example in the Emacs -sources. The other issue is that it's ok to use quote in an -edebug spec, so testcover needs to cope with that." -:expected-result :failed +See `c-make-font-lock-search-function' for an example in the +Emacs sources. `c-make-font-lock-search-function''s Edebug spec +also contains a quote. See comment in `testcover-analyze-coverage' +regarding the odd-looking coverage result for the quoted form." ;; ==== (defun testcover-testcase-make-function (forms) `(lambda (flag) (if flag 0 ,@forms%%%))%%%) @@ -462,7 +458,7 @@ edebug spec, so testcover needs to cope with that." (("quote" (&rest def-form)))) (defun testcover-testcase-thing () - (testcover-testcase-make-function '((+ 1 (+ 2 (+ 3 (+ 4 5))))))%%%) + (testcover-testcase-make-function '(!!!(+ 1 !!!(+ 2 !!!(+ 3 !!!(+ 4 5)%%%)%%%)%%%)%%%))%%%) (defun testcover-testcase-use-thing () (funcall (testcover-testcase-thing)%%% nil)%%%) @@ -494,10 +490,18 @@ edebug spec, so testcover needs to cope with that." "Testcover captures and ignores circular list errors." ;; ==== (defun testcover-testcase-cyc1 (a) - (let ((ls (make-list 10 a%%%))) - (nconc ls ls) - ls)) + (let ((ls (make-list 10 a%%%)%%%)) + (nconc ls%%% ls%%%) + ls)) ; The lack of a mark here is due to an ignored circular list error. (testcover-testcase-cyc1 1) (testcover-testcase-cyc1 1) +(defun testcover-testcase-cyc2 (a b) + (let ((ls1 (make-list 10 a%%%)%%%) + (ls2 (make-list 10 b))) + (nconc ls2 ls2) + (nconc ls1%%% ls2) + ls1)) +(testcover-testcase-cyc2 1 2) +(testcover-testcase-cyc2 1 4) ;; testcases.el ends here. diff --git a/test/lisp/emacs-lisp/testcover-tests.el b/test/lisp/emacs-lisp/testcover-tests.el index be48aa443b6..6c76421d38b 100644 --- a/test/lisp/emacs-lisp/testcover-tests.el +++ b/test/lisp/emacs-lisp/testcover-tests.el @@ -124,14 +124,12 @@ arguments for `testcover-start'." (save-current-buffer (set-buffer (find-file-noselect tempfile)) ;; Fail the test if the debugger tries to become active, - ;; which will happen if Testcover's reinstrumentation - ;; leaves an edebug-enter in the code. This will also - ;; prevent debugging these tests using Edebug. - (cl-letf (((symbol-function #'edebug-enter) + ;; which can happen if Testcover fails to attach itself + ;; correctly. Note that this will prevent debugging + ;; these tests using Edebug. + (cl-letf (((symbol-function #'edebug-default-enter) (lambda (&rest _args) - (ert-fail - (concat "Debugger invoked during test run " - "(possible edebug-enter not replaced)"))))) + (ert-fail "Debugger invoked during test run")))) (dolist (byte-compile '(t nil)) (testcover-tests-unmarkup-region (point-min) (point-max)) (unwind-protect diff --git a/test/lisp/emacs-lisp/thunk-tests.el b/test/lisp/emacs-lisp/thunk-tests.el index 4cc19f90d6c..b24e8d1fdb7 100644 --- a/test/lisp/emacs-lisp/thunk-tests.el +++ b/test/lisp/emacs-lisp/thunk-tests.el @@ -51,5 +51,55 @@ (thunk-force thunk) (should (= x 1)))) + + +;; thunk-let tests + +(ert-deftest thunk-let-basic-test () + "Test whether bindings are established." + (should (equal (thunk-let ((x 1) (y 2)) (+ x y)) 3))) + +(ert-deftest thunk-let*-basic-test () + "Test whether bindings are established." + (should (equal (thunk-let* ((x 1) (y (+ 1 x))) (+ x y)) 3))) + +(ert-deftest thunk-let-bound-vars-cant-be-set-test () + "Test whether setting a `thunk-let' bound variable fails." + (should-error + (eval '(thunk-let ((x 1)) (let ((y 7)) (setq x (+ x y)) (* 10 x))) t))) + +(ert-deftest thunk-let-laziness-test () + "Test laziness of `thunk-let'." + (should + (equal (let ((x-evalled nil) + (y-evalled nil)) + (thunk-let ((x (progn (setq x-evalled t) (+ 1 2))) + (y (progn (setq y-evalled t) (+ 3 4)))) + (let ((evalled-y y)) + (list x-evalled y-evalled evalled-y)))) + (list nil t 7)))) + +(ert-deftest thunk-let*-laziness-test () + "Test laziness of `thunk-let*'." + (should + (equal (let ((x-evalled nil) + (y-evalled nil) + (z-evalled nil) + (a-evalled nil)) + (thunk-let* ((x (progn (setq x-evalled t) (+ 1 1))) + (y (progn (setq y-evalled t) (+ x 1))) + (z (progn (setq z-evalled t) (+ y 1))) + (a (progn (setq a-evalled t) (+ z 1)))) + (let ((evalled-z z)) + (list x-evalled y-evalled z-evalled a-evalled evalled-z)))) + (list t t t nil 4)))) + +(ert-deftest thunk-let-bad-binding-test () + "Test whether a bad binding causes an error when expanding." + (should-error (macroexpand '(thunk-let ((x 1 1)) x))) + (should-error (macroexpand '(thunk-let (27) x))) + (should-error (macroexpand '(thunk-let x x)))) + + (provide 'thunk-tests) ;;; thunk-tests.el ends here diff --git a/test/lisp/gnus/gnus-tests.el b/test/lisp/gnus/gnus-tests.el index e149dccc258..fe1fc184147 100644 --- a/test/lisp/gnus/gnus-tests.el +++ b/test/lisp/gnus/gnus-tests.el @@ -26,8 +26,6 @@ ;;; Code: ;; registry.el is required by gnus-registry.el but this way we're explicit. -(eval-when-compile (require 'cl)) - (require 'registry) (require 'gnus-registry) diff --git a/test/lisp/help-fns-tests.el b/test/lisp/help-fns-tests.el index 5fd788c03fc..7e726eb7e8b 100644 --- a/test/lisp/help-fns-tests.el +++ b/test/lisp/help-fns-tests.el @@ -81,6 +81,11 @@ Return first line of the output of (describe-function-1 FUNC)." (result (help-fns-tests--describe-function 'search-forward-regexp))) (should (string-match regexp result)))) +(ert-deftest help-fns-test-dangling-alias () + "Make sure we don't burp on bogus aliases." + (let ((f (make-symbol "bogus-alias"))) + (define-obsolete-function-alias f 'help-fns-test--undefined-function "past") + (describe-symbol f))) ;;; Test describe-function over functions with funny names (defun abc\\\[universal-argument\]b\`c\'d\\e\"f (x) diff --git a/test/lisp/htmlfontify-tests.el b/test/lisp/htmlfontify-tests.el index 908c888af54..002415cadfe 100644 --- a/test/lisp/htmlfontify-tests.el +++ b/test/lisp/htmlfontify-tests.el @@ -36,7 +36,7 @@ available (Bug#25468)." (should (equal (let ((process-environment (cons "SHELL=/does/not/exist" process-environment))) (call-process - (expand-file-name (invocation-name) (invocation-directory)) + (expand-file-name invocation-name invocation-directory) nil nil nil "--quick" "--batch" (concat "--load=" (locate-library "htmlfontify")))) diff --git a/test/lisp/net/gnutls-tests.el b/test/lisp/net/gnutls-tests.el index c5bfe439d17..326e2416495 100644 --- a/test/lisp/net/gnutls-tests.el +++ b/test/lisp/net/gnutls-tests.el @@ -26,7 +26,7 @@ ;;; Code: (require 'ert) -(require 'cl) +(require 'cl-lib) (require 'gnutls) (require 'hex-util) @@ -46,22 +46,22 @@ (defvar gnutls-tests-tested-macs (when (gnutls-available-p) - (remove-duplicates - (append (mapcar 'cdr gnutls-tests-internal-macs-upcased) - (mapcar 'car (gnutls-macs)))))) + (cl-remove-duplicates + (append (mapcar #'cdr gnutls-tests-internal-macs-upcased) + (mapcar #'car (gnutls-macs)))))) (defvar gnutls-tests-tested-digests (when (gnutls-available-p) - (remove-duplicates - (append (mapcar 'cdr gnutls-tests-internal-macs-upcased) - (mapcar 'car (gnutls-digests)))))) + (cl-remove-duplicates + (append (mapcar #'cdr gnutls-tests-internal-macs-upcased) + (mapcar #'car (gnutls-digests)))))) (defvar gnutls-tests-tested-ciphers (when (gnutls-available-p) - (remove-duplicates - ; these cause FPEs or SEGVs - (remove-if (lambda (e) (memq e '(ARCFOUR-128))) - (mapcar 'car (gnutls-ciphers)))))) + (cl-remove-duplicates + ;; these cause FPEs or SEGVs + (cl-remove-if (lambda (e) (memq e '(ARCFOUR-128))) + (mapcar #'car (gnutls-ciphers)))))) (defvar gnutls-tests-mondo-strings (list @@ -154,7 +154,7 @@ ("0cc175b9c0f1b6a831c399e269772661" "a" MD5) ("a9993e364706816aba3e25717850c26c9cd0d89d" "abc" SHA1) ("a9993e364706816aba3e25717850c26c9cd0d89d" "abc" "SHA1"))) ; check string ID for digest - (destructuring-bind (hash input mac) test + (pcase-let ((`(,hash ,input ,mac) test)) (let ((plist (cdr (assq mac macs))) result resultb) (gnutls-tests-message "%s %S" mac plist) @@ -178,7 +178,7 @@ ("81568ba71fa2c5f33cc84bf362466988f98eba3735479100b4e8908acad87ac4" "more and more data goes into a file to exceed the buffer size" "very long key goes here to exceed the key size" SHA256) ("4bc830005783a73b8112f4bd5f4aa5f92e05b51e9b55c0cd6f9a7bee48371def" "more and more data goes into a file to exceed the buffer size" "" "SHA256") ; check string ID for HMAC ("4bc830005783a73b8112f4bd5f4aa5f92e05b51e9b55c0cd6f9a7bee48371def" "more and more data goes into a file to exceed the buffer size" "" SHA256))) - (destructuring-bind (hash input key mac) test + (pcase-let ((`(,hash ,input ,key ,mac) test)) (let ((plist (cdr (assq mac macs))) result) (gnutls-tests-message "%s %S" mac plist) @@ -214,7 +214,7 @@ (let ((keys '("mykey" "mykey2")) (inputs gnutls-tests-mondo-strings) (ivs '("" "-abc123-" "init" "ini2")) - (ciphers (remove-if + (ciphers (cl-remove-if (lambda (c) (plist-get (cdr (assq c (gnutls-ciphers))) :cipher-aead-capable)) gnutls-tests-tested-ciphers))) @@ -252,7 +252,7 @@ "auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data auth and auth of data " "AUTH data and more data to go over the block limit!" "AUTH data and more data to go over the block limit")) - (ciphers (remove-if + (ciphers (cl-remove-if (lambda (c) (or (null (plist-get (cdr (assq c (gnutls-ciphers))) :cipher-aead-capable)))) gnutls-tests-tested-ciphers)) diff --git a/test/lisp/net/tramp-archive-resources/foo.tar.gz b/test/lisp/net/tramp-archive-resources/foo.tar.gz Binary files differnew file mode 100644 index 00000000000..68925b147fc --- /dev/null +++ b/test/lisp/net/tramp-archive-resources/foo.tar.gz diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el new file mode 100644 index 00000000000..149ed370432 --- /dev/null +++ b/test/lisp/net/tramp-archive-tests.el @@ -0,0 +1,802 @@ +;;; tramp-archive-tests.el --- Tests of file archive access -*- lexical-binding:t -*- + +;; Copyright (C) 2017-2018 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> + +;; 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/'. + +;;; Code: + +;; The `tramp-archive-testnn-*' tests correspond to the respective +;; tests in tramp-tests.el. + +(require 'ert) +(require 'tramp-archive) + +(defconst tramp-archive-test-resource-directory + (let ((default-directory + (if load-in-progress + (file-name-directory load-file-name) + default-directory))) + (cond + ((file-accessible-directory-p (expand-file-name "resources")) + (expand-file-name "resources")) + ((file-accessible-directory-p (expand-file-name "tramp-archive-resources")) + (expand-file-name "tramp-archive-resources")))) + "The resources directory test files are located in.") + +(defconst tramp-archive-test-file-archive + (file-truename + (expand-file-name "foo.tar.gz" tramp-archive-test-resource-directory)) + "The test file archive.") + +(defconst tramp-archive-test-archive + (file-name-as-directory tramp-archive-test-file-archive) + "The test archive.") + +(setq password-cache-expiry nil + tramp-verbose 0 + tramp-cache-read-persistent-data t ;; For auth-sources. + tramp-copy-size-limit nil + tramp-message-show-message nil + tramp-persistency-file-name nil) + +(defun tramp-archive--test-make-temp-name () + "Return a temporary file name for test. +The temporary file is not created." + (expand-file-name + (make-temp-name "tramp-archive-test") temporary-file-directory)) + +(defun tramp-archive--test-delete (tmpfile) + "Delete temporary file or directory TMPFILE. +This needs special support, because archive file names, which are +the origin of the temporary TMPFILE, have no write permissions." + (unless (file-writable-p (file-name-directory tmpfile)) + (set-file-modes + (file-name-directory tmpfile) + (logior (file-modes (file-name-directory tmpfile)) #o0700))) + (set-file-modes tmpfile #o0700) + (if (file-regular-p tmpfile) + (delete-file tmpfile) + (mapc + 'tramp-archive--test-delete + (directory-files tmpfile 'full directory-files-no-dot-files-regexp)) + (delete-directory tmpfile))) + +(defun tramp-archive--test-emacs26-p () + "Check for Emacs version >= 26.1. +Some semantics has been changed for there, w/o new functions or +variables, so we check the Emacs version directly." + (>= emacs-major-version 26)) + +(ert-deftest tramp-archive-test00-availability () + "Test availability of Tramp functions." + :expected-result (if tramp-gvfs-enabled :passed :failed) + (should + (and + tramp-gvfs-enabled + (file-exists-p tramp-archive-test-file-archive) + (tramp-archive-file-name-p tramp-archive-test-archive)))) + +(ert-deftest tramp-archive-test01-file-name-syntax () + "Check archive file name syntax." + (should-not (tramp-archive-file-name-p tramp-archive-test-file-archive)) + (should (tramp-archive-file-name-p tramp-archive-test-archive)) + (should (tramp-archive-file-name-p (concat tramp-archive-test-archive "foo"))) + (should + (tramp-archive-file-name-p (concat tramp-archive-test-archive "foo/bar"))) + ;; A file archive inside a file archive. + (should + (tramp-archive-file-name-p (concat tramp-archive-test-archive "foo.tar"))) + (should + (tramp-archive-file-name-p (concat tramp-archive-test-archive "foo.tar/")))) + +(ert-deftest tramp-archive-test02-file-name-dissect () + "Check archive file name components." + (skip-unless tramp-gvfs-enabled) + + (with-parsed-tramp-archive-file-name tramp-archive-test-archive nil + (should (string-equal method tramp-archive-method)) + (should-not user) + (should-not domain) + (should + (string-equal + host + (file-remote-p + (tramp-archive-gvfs-file-name tramp-archive-test-archive) 'host))) + (should + (string-equal + host + (url-hexify-string (concat "file://" tramp-archive-test-file-archive)))) + (should-not port) + (should (string-equal localname "/")) + (should (string-equal archive tramp-archive-test-file-archive))) + + ;; Localname. + (with-parsed-tramp-archive-file-name + (concat tramp-archive-test-archive "foo") nil + (should (string-equal method tramp-archive-method)) + (should-not user) + (should-not domain) + (should + (string-equal + host + (file-remote-p + (tramp-archive-gvfs-file-name tramp-archive-test-archive) 'host))) + (should + (string-equal + host + (url-hexify-string (concat "file://" tramp-archive-test-file-archive)))) + (should-not port) + (should (string-equal localname "/foo")) + (should (string-equal archive tramp-archive-test-file-archive))) + + ;; File archive in file archive. + (let* ((tramp-archive-test-file-archive + (concat tramp-archive-test-archive "bar.tar")) + (tramp-archive-test-archive + (file-name-as-directory tramp-archive-test-file-archive)) + (tramp-methods (cons `(,tramp-archive-method) tramp-methods)) + (tramp-gvfs-methods tramp-archive-all-gvfs-methods)) + (unwind-protect + (with-parsed-tramp-archive-file-name tramp-archive-test-archive nil + (should (string-equal method tramp-archive-method)) + (should-not user) + (should-not domain) + (should + (string-equal + host + (file-remote-p + (tramp-archive-gvfs-file-name tramp-archive-test-archive) 'host))) + ;; We reimplement the logic of tramp-archive.el here. Don't + ;; know, whether it is worth the test. + (should + (string-equal + host + (url-hexify-string + (concat + (tramp-gvfs-url-file-name + (tramp-make-tramp-file-name + tramp-archive-method + ;; User and Domain. + nil nil + ;; Host. + (url-hexify-string + (concat + "file://" + ;; `directory-file-name' does not leave file archive + ;; boundaries. So we must cut the trailing slash + ;; ourselves. + (substring + (file-name-directory tramp-archive-test-file-archive) 0 -1))) + nil "/")) + (file-name-nondirectory tramp-archive-test-file-archive))))) + (should-not port) + (should (string-equal localname "/")) + (should (string-equal archive tramp-archive-test-file-archive))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test05-expand-file-name () + "Check `expand-file-name'." + (should + (string-equal + (expand-file-name "/foo.tar/path/./file") "/foo.tar/path/file")) + (should + (string-equal (expand-file-name "/foo.tar/path/../file") "/foo.tar/file")) + ;; `expand-file-name' does not care "~/" in archive file names. + (should + (string-equal (expand-file-name "/foo.tar/~/file") "/foo.tar/~/file")) + ;; `expand-file-name' does not care file archive boundaries. + (should (string-equal (expand-file-name "/foo.tar/./file") "/foo.tar/file")) + (should (string-equal (expand-file-name "/foo.tar/../file") "/file"))) + +(ert-deftest tramp-archive-test06-directory-file-name () + "Check `directory-file-name'. +This checks also `file-name-as-directory', `file-name-directory', +`file-name-nondirectory' and `unhandled-file-name-directory'." + (skip-unless tramp-gvfs-enabled) + + (should + (string-equal + (directory-file-name "/foo.tar/path/to/file") "/foo.tar/path/to/file")) + (should + (string-equal + (directory-file-name "/foo.tar/path/to/file/") "/foo.tar/path/to/file")) + ;; `directory-file-name' does not leave file archive boundaries. + (should (string-equal (directory-file-name "/foo.tar/") "/foo.tar/")) + + (should + (string-equal + (file-name-as-directory "/foo.tar/path/to/file") "/foo.tar/path/to/file/")) + (should + (string-equal + (file-name-as-directory "/foo.tar/path/to/file/") "/foo.tar/path/to/file/")) + (should (string-equal (file-name-as-directory "/foo.tar/") "/foo.tar/")) + (should (string-equal (file-name-as-directory "/foo.tar") "/foo.tar/")) + + (should + (string-equal + (file-name-directory "/foo.tar/path/to/file") "/foo.tar/path/to/")) + (should + (string-equal + (file-name-directory "/foo.tar/path/to/file/") "/foo.tar/path/to/file/")) + (should (string-equal (file-name-directory "/foo.tar/") "/foo.tar/")) + + (should + (string-equal (file-name-nondirectory "/foo.tar/path/to/file") "file")) + (should + (string-equal (file-name-nondirectory "/foo.tar/path/to/file/") "")) + (should (string-equal (file-name-nondirectory "/foo.tar/") "")) + + (should-not + (unhandled-file-name-directory "/foo.tar/path/to/file"))) + +(ert-deftest tramp-archive-test07-file-exists-p () + "Check `file-exist-p', `write-region' and `delete-file'." + (skip-unless tramp-gvfs-enabled) + + (unwind-protect + (let ((default-directory tramp-archive-test-archive)) + (should (file-exists-p tramp-archive-test-file-archive)) + (should (file-exists-p tramp-archive-test-archive)) + (should (file-exists-p "foo.txt")) + (should (file-exists-p "foo.lnk")) + (should (file-exists-p "bar")) + (should (file-exists-p "bar/bar")) + (should-error + (write-region "foo" nil "baz") + :type 'file-error) + (should-error + (delete-file "baz") + :type 'file-error)) + + ;; Cleanup. + (tramp-archive-cleanup-hash))) + +(ert-deftest tramp-archive-test08-file-local-copy () + "Check `file-local-copy'." + (skip-unless tramp-gvfs-enabled) + + (let (tmp-name) + (unwind-protect + (progn + (should + (setq tmp-name + (file-local-copy + (expand-file-name "bar/bar" tramp-archive-test-archive)))) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "bar\n"))) + ;; Error case. + (tramp-archive--test-delete tmp-name) + (should-error + (setq tmp-name + (file-local-copy + (expand-file-name "what" tramp-archive-test-archive))) + :type tramp-file-missing)) + + ;; Cleanup. + (ignore-errors + (tramp-archive--test-delete tmp-name) + (tramp-archive-cleanup-hash))))) + +(ert-deftest tramp-archive-test09-insert-file-contents () + "Check `insert-file-contents'." + (skip-unless tramp-gvfs-enabled) + + (let ((tmp-name (expand-file-name "bar/bar" tramp-archive-test-archive))) + (unwind-protect + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "bar\n")) + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "bar\nbar\n")) + ;; Insert partly. + (insert-file-contents tmp-name nil 1 3) + (should (string-equal (buffer-string) "arbar\nbar\n")) + ;; Replace. + (insert-file-contents tmp-name nil nil nil 'replace) + (should (string-equal (buffer-string) "bar\n")) + ;; Error case. + (should-error + (insert-file-contents + (expand-file-name "what" tramp-archive-test-archive)) + :type tramp-file-missing)) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test11-copy-file () + "Check `copy-file'." + (skip-unless tramp-gvfs-enabled) + + ;; Copy simple file. + (let ((tmp-name1 (expand-file-name "bar/bar" tramp-archive-test-archive)) + (tmp-name2 (tramp-archive--test-make-temp-name))) + (unwind-protect + (progn + (copy-file tmp-name1 tmp-name2) + (should (file-exists-p tmp-name2)) + (with-temp-buffer + (insert-file-contents tmp-name2) + (should (string-equal (buffer-string) "bar\n"))) + (should-error + (copy-file tmp-name1 tmp-name2) + :type 'file-already-exists) + (copy-file tmp-name1 tmp-name2 'ok) + ;; The file archive is not writable. + (should-error + (copy-file tmp-name2 tmp-name1 'ok) + :type 'file-error)) + + ;; Cleanup. + (ignore-errors (tramp-archive--test-delete tmp-name2)) + (tramp-archive-cleanup-hash))) + + ;; Copy directory to existing directory. + (let ((tmp-name1 (expand-file-name "bar" tramp-archive-test-archive)) + (tmp-name2 (tramp-archive--test-make-temp-name))) + (unwind-protect + (progn + (make-directory tmp-name2) + (should (file-directory-p tmp-name2)) + ;; Directory `tmp-name2' exists already, so we must use + ;; `file-name-as-directory'. + (copy-file tmp-name1 (file-name-as-directory tmp-name2)) + (should + (file-exists-p + (expand-file-name + (concat (file-name-nondirectory tmp-name1) "/bar") tmp-name2)))) + + ;; Cleanup. + (ignore-errors (tramp-archive--test-delete tmp-name2)) + (tramp-archive-cleanup-hash))) + + ;; Copy directory/file to non-existing directory. + (let ((tmp-name1 (expand-file-name "bar" tramp-archive-test-archive)) + (tmp-name2 (tramp-archive--test-make-temp-name))) + (unwind-protect + (progn + (make-directory tmp-name2) + (should (file-directory-p tmp-name2)) + (copy-file + tmp-name1 + (expand-file-name (file-name-nondirectory tmp-name1) tmp-name2)) + (should + (file-exists-p + (expand-file-name + (concat (file-name-nondirectory tmp-name1) "/bar") tmp-name2)))) + + ;; Cleanup. + (ignore-errors (tramp-archive--test-delete tmp-name2)) + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test15-copy-directory () + "Check `copy-directory'." + (skip-unless tramp-gvfs-enabled) + + (let* ((tmp-name1 (expand-file-name "bar" tramp-archive-test-archive)) + (tmp-name2 (tramp-archive--test-make-temp-name)) + (tmp-name3 (expand-file-name + (file-name-nondirectory tmp-name1) tmp-name2)) + (tmp-name4 (expand-file-name "bar" tmp-name2)) + (tmp-name5 (expand-file-name "bar" tmp-name3))) + + ;; Copy complete directory. + (unwind-protect + (progn + ;; Copy empty directory. + (copy-directory tmp-name1 tmp-name2) + (should (file-directory-p tmp-name2)) + (should (file-exists-p tmp-name4)) + ;; Target directory does exist already. + ;; This has been changed in Emacs 26.1. + (when (tramp-archive--test-emacs26-p) + (should-error + (copy-directory tmp-name1 tmp-name2) + :type 'file-error)) + (tramp-archive--test-delete tmp-name4) + (copy-directory tmp-name1 (file-name-as-directory tmp-name2)) + (should (file-directory-p tmp-name3)) + (should (file-exists-p tmp-name5))) + + ;; Cleanup. + (ignore-errors (tramp-archive--test-delete tmp-name2)) + (tramp-archive-cleanup-hash)) + + ;; Copy directory contents. + (unwind-protect + (progn + ;; Copy empty directory. + (copy-directory tmp-name1 tmp-name2 nil 'parents 'contents) + (should (file-directory-p tmp-name2)) + (should (file-exists-p tmp-name4)) + ;; Target directory does exist already. + (tramp-archive--test-delete tmp-name4) + (copy-directory + tmp-name1 (file-name-as-directory tmp-name2) + nil 'parents 'contents) + (should (file-directory-p tmp-name2)) + (should (file-exists-p tmp-name4)) + (should-not (file-directory-p tmp-name3)) + (should-not (file-exists-p tmp-name5))) + + ;; Cleanup. + (ignore-errors (tramp-archive--test-delete tmp-name2)) + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test16-directory-files () + "Check `directory-files'." + (skip-unless tramp-gvfs-enabled) + + (let ((tmp-name tramp-archive-test-archive) + (files '("." ".." "bar" "foo.hrd" "foo.lnk" "foo.txt"))) + (unwind-protect + (progn + (should (file-directory-p tmp-name)) + (should (equal (directory-files tmp-name) files)) + (should (equal (directory-files tmp-name 'full) + (mapcar (lambda (x) (concat tmp-name x)) files))) + (should (equal (directory-files + tmp-name nil directory-files-no-dot-files-regexp) + (delete "." (delete ".." files)))) + (should (equal (directory-files + tmp-name 'full directory-files-no-dot-files-regexp) + (mapcar (lambda (x) (concat tmp-name x)) + (delete "." (delete ".." files)))))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test17-insert-directory () + "Check `insert-directory'." + (skip-unless tramp-gvfs-enabled) + + (let (;; We test for the summary line. Keyword "total" could be localized. + (process-environment + (append '("LANG=C" "LANGUAGE=C" "LC_ALL=C") process-environment))) + (unwind-protect + (progn + ;; Due to Bug#29423, this works only since for Emacs 26.1. + (when nil ;; TODO (tramp-archive--test-emacs26-p) + (with-temp-buffer + (insert-directory tramp-archive-test-archive nil) + (goto-char (point-min)) + (should + (looking-at-p (regexp-quote tramp-archive-test-archive))))) + (with-temp-buffer + (insert-directory tramp-archive-test-archive "-al") + (goto-char (point-min)) + (should + (looking-at-p + (format "^.+ %s$" (regexp-quote tramp-archive-test-archive))))) + (with-temp-buffer + (insert-directory + (file-name-as-directory tramp-archive-test-archive) + "-al" nil 'full-directory-p) + (goto-char (point-min)) + (should + (looking-at-p + (concat + ;; There might be a summary line. + "\\(total.+[[:digit:]]+\n\\)?" + ;; We don't know in which order the files appear. + (format + "\\(.+ %s\\( ->.+\\)?\n\\)\\{%d\\}" + (regexp-opt (directory-files tramp-archive-test-archive)) + (length (directory-files tramp-archive-test-archive)))))))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test18-file-attributes () + "Check `file-attributes'. +This tests also `file-readable-p' and `file-regular-p'." + (skip-unless tramp-gvfs-enabled) + + (let ((tmp-name1 (expand-file-name "foo.txt" tramp-archive-test-archive)) + (tmp-name2 (expand-file-name "foo.lnk" tramp-archive-test-archive)) + (tmp-name3 (expand-file-name "bar" tramp-archive-test-archive)) + attr) + (unwind-protect + (progn + (should (file-exists-p tmp-name1)) + (should (file-readable-p tmp-name1)) + (should (file-regular-p tmp-name1)) + + ;; We do not test inodes and device numbers. + (setq attr (file-attributes tmp-name1)) + (should (consp attr)) + (should (null (car attr))) + (should (numberp (nth 1 attr))) ;; Link. + (should (numberp (nth 2 attr))) ;; Uid. + (should (numberp (nth 3 attr))) ;; Gid. + ;; Last access time. + (should (stringp (current-time-string (nth 4 attr)))) + ;; Last modification time. + (should (stringp (current-time-string (nth 5 attr)))) + ;; Last status change time. + (should (stringp (current-time-string (nth 6 attr)))) + (should (numberp (nth 7 attr))) ;; Size. + (should (stringp (nth 8 attr))) ;; Modes. + + (setq attr (file-attributes tmp-name1 'string)) + (should (stringp (nth 2 attr))) ;; Uid. + (should (stringp (nth 3 attr))) ;; Gid. + + ;; Symlink. + (should (file-exists-p tmp-name2)) + (should (file-symlink-p tmp-name2)) + (setq attr (file-attributes tmp-name2)) + (should (string-equal (car attr) (file-name-nondirectory tmp-name1))) + + ;; Directory. + (should (file-exists-p tmp-name3)) + (should (file-readable-p tmp-name3)) + (should-not (file-regular-p tmp-name3)) + (setq attr (file-attributes tmp-name3)) + (should (eq (car attr) t))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test19-directory-files-and-attributes () + "Check `directory-files-and-attributes'." + (skip-unless tramp-gvfs-enabled) + + (let ((tmp-name (expand-file-name "bar" tramp-archive-test-archive)) + attr) + (unwind-protect + (progn + (should (file-directory-p tmp-name)) + (setq attr (directory-files-and-attributes tmp-name)) + (should (consp attr)) + (dolist (elt attr) + (should + (equal (file-attributes (expand-file-name (car elt) tmp-name)) + (cdr elt)))) + (setq attr (directory-files-and-attributes tmp-name 'full)) + (dolist (elt attr) + (should (equal (file-attributes (car elt)) (cdr elt)))) + (setq attr (directory-files-and-attributes tmp-name nil "^b")) + (should (equal (mapcar 'car attr) '("bar")))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test20-file-modes () + "Check `file-modes'. +This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." + (skip-unless tramp-gvfs-enabled) + + (let ((tmp-name1 (expand-file-name "foo.txt" tramp-archive-test-archive)) + (tmp-name2 (expand-file-name "bar" tramp-archive-test-archive))) + (unwind-protect + (progn + (should (file-exists-p tmp-name1)) + ;; `set-file-modes' is not implemented. + (should-error + (set-file-modes tmp-name1 #o777) + :type 'file-error) + (should (= (file-modes tmp-name1) #o400)) + (should-not (file-executable-p tmp-name1)) + (should-not (file-writable-p tmp-name1)) + + (should (file-exists-p tmp-name2)) + ;; `set-file-modes' is not implemented. + (should-error + (set-file-modes tmp-name2 #o777) + :type 'file-error) + (should (= (file-modes tmp-name2) #o500)) + (should (file-executable-p tmp-name2)) + (should-not (file-writable-p tmp-name2))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test21-file-links () + "Check `file-symlink-p' and `file-truename'" + (skip-unless tramp-gvfs-enabled) + + ;; We must use `file-truename' for the file archive, because it + ;; could be located on a symlinked directory. This would let the + ;; test fail. + (let* ((tramp-archive-test-archive (file-truename tramp-archive-test-archive)) + (tmp-name1 (expand-file-name "foo.txt" tramp-archive-test-archive)) + (tmp-name2 (expand-file-name "foo.lnk" tramp-archive-test-archive))) + + (unwind-protect + (progn + (should (file-exists-p tmp-name1)) + (should (string-equal tmp-name1 (file-truename tmp-name1))) + ;; `make-symbolic-link' is not implemented. + (should-error + (make-symbolic-link tmp-name1 tmp-name2) + :type 'file-error) + (should (file-symlink-p tmp-name2)) + (should + (string-equal + ;; This is "/foo.txt". + (with-parsed-tramp-archive-file-name tmp-name1 nil localname) + ;; `file-symlink-p' returns "foo.txt". Wer must expand, therefore. + (with-parsed-tramp-archive-file-name + (expand-file-name + (file-symlink-p tmp-name2) tramp-archive-test-archive) + nil + localname))) + (should-not (string-equal tmp-name2 (file-truename tmp-name2))) + (should + (string-equal (file-truename tmp-name1) (file-truename tmp-name2))) + (should (file-equal-p tmp-name1 tmp-name2))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +(ert-deftest tramp-archive-test26-file-name-completion () + "Check `file-name-completion' and `file-name-all-completions'." + (skip-unless tramp-gvfs-enabled) + + (let ((tmp-name tramp-archive-test-archive)) + (unwind-protect + (progn + ;; Local files. + (should (equal (file-name-completion "fo" tmp-name) "foo.")) + (should (equal (file-name-completion "foo.txt" tmp-name) t)) + (should (equal (file-name-completion "b" tmp-name) "bar/")) + (should-not (file-name-completion "a" tmp-name)) + (should + (equal + (file-name-completion "b" tmp-name 'file-directory-p) "bar/")) + (should + (equal + (sort (file-name-all-completions "fo" tmp-name) 'string-lessp) + '("foo.hrd" "foo.lnk" "foo.txt"))) + (should + (equal + (sort (file-name-all-completions "b" tmp-name) 'string-lessp) + '("bar/"))) + (should-not (file-name-all-completions "a" tmp-name)) + ;; `completion-regexp-list' restricts the completion to + ;; files which match all expressions in this list. + (let ((completion-regexp-list + `(,directory-files-no-dot-files-regexp "b"))) + (should + (equal (file-name-completion "" tmp-name) "bar/")) + (should + (equal + (sort (file-name-all-completions "" tmp-name) 'string-lessp) + '("bar/"))))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)))) + +;; The functions were introduced in Emacs 26.1. +(ert-deftest tramp-archive-test37-make-nearby-temp-file () + "Check `make-nearby-temp-file' and `temporary-file-directory'." + (skip-unless tramp-gvfs-enabled) + ;; Since Emacs 26.1. + (skip-unless + (and (fboundp 'make-nearby-temp-file) (fboundp 'temporary-file-directory))) + + ;; `make-nearby-temp-file' and `temporary-file-directory' exists + ;; since Emacs 26.1. We don't want to see compiler warnings for + ;; older Emacsen. + (let ((default-directory tramp-archive-test-archive) + tmp-file) + ;; The file archive shall know a temporary file directory. It is + ;; not in the archive itself. + (should + (stringp (with-no-warnings (with-no-warnings (temporary-file-directory))))) + (should-not + (tramp-archive-file-name-p (with-no-warnings (temporary-file-directory)))) + + ;; A temporary file or directory shall not be located in the + ;; archive itself. + (setq tmp-file + (with-no-warnings (make-nearby-temp-file "tramp-archive-test"))) + (should (file-exists-p tmp-file)) + (should (file-regular-p tmp-file)) + (should-not (tramp-archive-file-name-p tmp-file)) + (delete-file tmp-file) + (should-not (file-exists-p tmp-file)) + + (setq tmp-file + (with-no-warnings (make-nearby-temp-file "tramp-archive-test" 'dir))) + (should (file-exists-p tmp-file)) + (should (file-directory-p tmp-file)) + (should-not (tramp-archive-file-name-p tmp-file)) + (delete-directory tmp-file) + (should-not (file-exists-p tmp-file)))) + +(ert-deftest tramp-archive-test40-archive-file-system-info () + "Check that `file-system-info' returns proper values." + (skip-unless tramp-gvfs-enabled) + ;; Since Emacs 27.1. + (skip-unless (fboundp 'file-system-info)) + + ;; `file-system-info' exists since Emacs 27. We don't want to see + ;; compiler warnings for older Emacsen. + (let ((fsi (with-no-warnings (file-system-info tramp-archive-test-archive)))) + (skip-unless fsi) + (should (and (consp fsi) + (= (length fsi) 3) + (numberp (nth 0 fsi)) + ;; FREE and AVAIL are always 0. + (zerop (nth 1 fsi)) + (zerop (nth 2 fsi)))))) + +(ert-deftest tramp-archive-test99-libarchive-tests () + "Run tests of libarchive test files." + :tags '(:expensive-test) + (skip-unless tramp-gvfs-enabled) + ;; We do not want to run unless chosen explicitly. This test makes + ;; sense only in my local environment. Michael Albinus. + (skip-unless + (equal + (ert--stats-selector ert--current-run-stats) + (ert-test-name (ert-running-test)))) + + (url-handler-mode) + (unwind-protect + (dolist (dir + '("~/Downloads" "/sftp::~/Downloads" "/ssh::~/Downloads" + "http://ftp.debian.org/debian/pool/main/c/coreutils")) + (dolist + (file + '("coreutils_8.26-3_amd64.deb" + "coreutils_8.26-3ubuntu3_amd64.deb")) + (setq file (expand-file-name file dir)) + (when (file-exists-p file) + (setq file (expand-file-name "control.tar.gz/control" file)) + (message "%s" file) + (should (file-attributes (file-name-as-directory file)))))) + + ;; Cleanup. + (tramp-archive-cleanup-hash)) + + (unwind-protect + (dolist (dir '("" "/sftp::" "/ssh::")) + (dolist + (file + (apply + 'append + (mapcar + (lambda (x) (directory-files (concat dir x) 'full "uu\\'" 'sort)) + '("~/src/libarchive-3.2.2/libarchive/test" + "~/src/libarchive-3.2.2/cpio/test" + "~/src/libarchive-3.2.2/tar/test")))) + (setq file (file-name-as-directory file)) + (cond + ((not (tramp-archive-file-name-p file)) + (message "skipped: %s" file)) + ((file-attributes file) + (message "%s" file)) + (t (message "failed: %s" file))) + (tramp-archive-cleanup-hash))) + + ;; Cleanup. + (tramp-archive-cleanup-hash))) + +(defun tramp-archive-test-all (&optional interactive) + "Run all tests for \\[tramp-archive]." + (interactive "p") + (funcall + (if interactive 'ert-run-tests-interactively 'ert-run-tests-batch) + "^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 49d506bdd9e..24dfee55134 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -33,12 +33,17 @@ ;; remote host, set this environment variable to "/dev/null" or ;; whatever is appropriate on your system. +;; For slow remote connections, `tramp-test41-asynchronous-requests' +;; might be too heavy. Setting $REMOTE_PARALLEL_PROCESSES to a proper +;; value less than 10 could help. + ;; A whole test run can be performed calling the command `tramp-test-all'. ;;; Code: (require 'dired) (require 'ert) +(require 'ert-x) (require 'tramp) (require 'vc) (require 'vc-bzr) @@ -53,8 +58,15 @@ (defvar tramp-copy-size-limit) (defvar tramp-persistency-file-name) (defvar tramp-remote-process-environment) -;; Suppress nasty messages. -(fset 'shell-command-sentinel 'ignore) + +;; Beautify batch mode. +(when noninteractive + ;; Suppress nasty messages. + (fset 'shell-command-sentinel 'ignore) + ;; We do not want to be interrupted. + (eval-after-load 'tramp-gvfs + '(fset 'tramp-gvfs-handler-askquestion + (lambda (_message _choices) '(t nil 0))))) ;; There is no default value on w32 systems, which could work out of the box. (defconst tramp-test-temporary-file-directory @@ -1862,6 +1874,23 @@ This checks also `file-name-as-directory', `file-name-directory', (insert-file-contents tmp-name) (should (string-equal (buffer-string) "34"))) + ;; 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)) + (dolist (noninteractive '(nil t)) + (dolist (visit '(nil t "string" no-message)) + (ert-with-message-capture tramp--test-messages + (write-region "foo" nil tmp-name nil visit) + ;; We must check the last line. There could be + ;; other messages from the progress reporter. + (should + (string-match + (if (and (null noninteractive) + (or (eq visit t) (null visit) (stringp visit))) + (format "^Wrote %s\n\\'" tmp-name) "^\\'") + tramp--test-messages)))))))) + ;; Do not overwrite if excluded. (cl-letf (((symbol-function 'y-or-n-p) (lambda (_prompt) t))) (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) @@ -1919,7 +1948,9 @@ This checks also `file-name-as-directory', `file-name-directory', ;; Copy file to directory. (unwind-protect - (progn + ;; FIXME: This fails on my QNAP server, see + ;; /share/Web/owncloud/data/owncloud.log + (unless (tramp--test-owncloud-p) (write-region "foo" nil source) (should (file-exists-p source)) (make-directory target) @@ -1940,7 +1971,11 @@ This checks also `file-name-as-directory', `file-name-directory', ;; Copy directory to existing directory. (unwind-protect - (progn + ;; FIXME: This fails on my QNAP server, see + ;; /share/Web/owncloud/data/owncloud.log + (unless (and (tramp--test-owncloud-p) + (or (not (file-remote-p source)) + (not (file-remote-p target)))) (make-directory source) (should (file-directory-p source)) (write-region "foo" nil (expand-file-name "foo" source)) @@ -1961,7 +1996,10 @@ This checks also `file-name-as-directory', `file-name-directory', ;; Copy directory/file to non-existing directory. (unwind-protect - (progn + ;; FIXME: This fails on my QNAP server, see + ;; /share/Web/owncloud/data/owncloud.log + (unless + (and (tramp--test-owncloud-p) (not (file-remote-p source))) (make-directory source) (should (file-directory-p source)) (write-region "foo" nil (expand-file-name "foo" source)) @@ -2047,7 +2085,9 @@ This checks also `file-name-as-directory', `file-name-directory', ;; Rename directory to existing directory. (unwind-protect - (progn + ;; FIXME: This fails on my QNAP server, see + ;; /share/Web/owncloud/data/owncloud.log + (unless (tramp--test-owncloud-p) (make-directory source) (should (file-directory-p source)) (write-region "foo" nil (expand-file-name "foo" source)) @@ -2069,7 +2109,9 @@ This checks also `file-name-as-directory', `file-name-directory', ;; Rename directory/file to non-existing directory. (unwind-protect - (progn + ;; FIXME: This fails on my QNAP server, see + ;; /share/Web/owncloud/data/owncloud.log + (unless (tramp--test-owncloud-p) (make-directory source) (should (file-directory-p source)) (write-region "foo" nil (expand-file-name "foo" source)) @@ -2718,9 +2760,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (file-symlink-p tmp-name2))) ;; `tmp-name3' is a local file name. Therefore, the link ;; target remains unchanged, even if quoted. - (make-symbolic-link tmp-name1 tmp-name3) - (should - (string-equal tmp-name1 (file-symlink-p tmp-name3))) + ;; `make-symbolic-link' might not be permitted on w32 systems. + (unless (tramp--test-windows-nt) + (make-symbolic-link tmp-name1 tmp-name3) + (should + (string-equal tmp-name1 (file-symlink-p tmp-name3)))) ;; Check directory as newname. (make-directory tmp-name4) (should-error @@ -2822,15 +2866,17 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (tramp-compat-file-name-quote (concat (file-remote-p tmp-name2) "/penguin:motd:")))) ;; `tmp-name3' is a local file name. - (make-symbolic-link tmp-name1 tmp-name3) - (should (file-symlink-p tmp-name3)) - (should-not (string-equal tmp-name3 (file-truename tmp-name3))) - ;; `file-truename' returns a quoted file name for `tmp-name3'. - ;; We must unquote it. - (should - (string-equal - (tramp-compat-file-name-unquote (file-truename tmp-name1)) - (tramp-compat-file-name-unquote (file-truename tmp-name3))))) + ;; `make-symbolic-link' might not be permitted on w32 systems. + (unless (tramp--test-windows-nt) + (make-symbolic-link tmp-name1 tmp-name3) + (should (file-symlink-p tmp-name3)) + (should-not (string-equal tmp-name3 (file-truename tmp-name3))) + ;; `file-truename' returns a quoted file name for `tmp-name3'. + ;; We must unquote it. + (should + (string-equal + (tramp-compat-file-name-unquote (file-truename tmp-name1)) + (tramp-compat-file-name-unquote (file-truename tmp-name3)))))) ;; Cleanup. (ignore-errors @@ -2877,9 +2923,15 @@ 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)) - (make-symbolic-link tmp-name1 tmp-name2) - (should (file-symlink-p tmp-name2)) - (should-error (file-truename tmp-name1) :type 'file-error)) + (if (tramp-smb-file-name-p tramp-test-temporary-file-directory) + ;; The symlink command of `smbclient' detects the + ;; cycle already. + (should-error + (make-symbolic-link tmp-name1 tmp-name2) + :type 'file-error) + (make-symbolic-link tmp-name1 tmp-name2) + (should (file-symlink-p tmp-name2)) + (should-error (file-truename tmp-name1) :type 'file-error))) ;; Cleanup. (ignore-errors @@ -3773,11 +3825,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (vc-register (list (car vc-handled-backends) (list (file-name-nondirectory tmp-name2)))) - ;; `vc-register' has changed its arguments in Emacs 25.1. - (error - (vc-register - nil (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 (>= emacs-major-version 25)))) ;; 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) "/")) @@ -3915,9 +3965,14 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (expand-file-name (format "%s~" - ;; This is taken from `make-backup-file-name-1'. + ;; This is taken from `make-backup-file-name-1'. We + ;; call `convert-standard-filename', because on MS + ;; Windows the (local) colons must be replaced by + ;; exclamation marks. (subst-char-in-string - ?/ ?! (replace-regexp-in-string "!" "!!" tmp-name1))) + ?/ ?! + (replace-regexp-in-string + "!" "!!" (convert-standard-filename tmp-name1)))) tmp-name2))))) ;; The backup directory is created. (should (file-directory-p tmp-name2))) @@ -3938,9 +3993,14 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (expand-file-name (format "%s~" - ;; This is taken from `make-backup-file-name-1'. + ;; This is taken from `make-backup-file-name-1'. We + ;; call `convert-standard-filename', because on MS + ;; Windows the (local) colons must be replaced by + ;; exclamation marks. (subst-char-in-string - ?/ ?! (replace-regexp-in-string "!" "!!" tmp-name1))) + ?/ ?! + (replace-regexp-in-string + "!" "!!" (convert-standard-filename tmp-name1)))) tmp-name2))))) ;; The backup directory is created. (should (file-directory-p tmp-name2))) @@ -3962,9 +4022,14 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (expand-file-name (format "%s~" - ;; This is taken from `make-backup-file-name-1'. + ;; This is taken from `make-backup-file-name-1'. We + ;; call `convert-standard-filename', because on MS + ;; Windows the (local) colons must be replaced by + ;; exclamation marks. (subst-char-in-string - ?/ ?! (replace-regexp-in-string "!" "!!" tmp-name1))) + ?/ ?! + (replace-regexp-in-string + "!" "!!" (convert-standard-filename tmp-name1)))) tmp-name2))))) ;; The backup directory is created. (should (file-directory-p tmp-name2))) @@ -4053,6 +4118,11 @@ This does not support external Emacs calls." (string-equal "mock" (file-remote-p tramp-test-temporary-file-directory 'method))) +(defun tramp--test-owncloud-p () + "Check, whether the owncloud method is used." + (string-equal + "owncloud" (file-remote-p tramp-test-temporary-file-directory 'method))) + (defun tramp--test-rsync-p () "Check, whether the rsync method is used. This does not support special file names." @@ -4065,6 +4135,10 @@ This does not support special file names." (tramp-find-foreign-file-name-handler tramp-test-temporary-file-directory) 'tramp-sh-file-name-handler)) +(defun tramp--test-windows-nt () + "Check, whether the locale host runs MS Windows." + (eq system-type 'windows-nt)) + (defun tramp--test-windows-nt-and-batch () "Check, whether the locale host runs MS Windows in batch mode. This does not support special characters." @@ -4482,6 +4556,7 @@ process sentinels. They shall not disturb each other." ;; seconds, and we send a SIGUSR1 signal after 300 seconds. (with-timeout (300 (tramp--test-timeout-handler)) (define-key special-event-map [sigusr1] 'tramp--test-timeout-handler) + (tramp--test-instrument-test-case (if (getenv "EMACS_HYDRA_CI") 10 0) (let* (;; For the watchdog. (default-directory (expand-file-name temporary-file-directory)) (watchdog @@ -4497,8 +4572,13 @@ process sentinels. They shall not disturb each other." (inhibit-message t) ;; Do not run delayed timers. (timer-max-repeats 0) - ;; Number of asynchronous processes for test. - (number-proc 10) + ;; Number of asynchronous processes for test. Tests on + ;; some machines handle less parallel processes. + (number-proc + (or + (ignore-errors + (string-to-number (getenv "REMOTE_PARALLEL_PROCESSES"))) + 10)) ;; On hydra, timings are bad. (timer-repeat (cond @@ -4528,11 +4608,16 @@ process sentinels. They shall not disturb each other." (default-directory tmp-name) (file (buffer-name (nth (random (length buffers)) buffers)))) + (tramp--test-message + "Start timer %s %s" file (current-time-string)) (funcall timer-operation file) ;; Adjust timer if it takes too much time. (when (> (- (float-time) time) timer-repeat) (setq timer-repeat (* 1.5 timer-repeat)) - (setf (timer--repeat-delay timer) timer-repeat))))))) + (setf (timer--repeat-delay timer) timer-repeat) + (tramp--test-message "Increase timer %s" timer-repeat)) + (tramp--test-message + "Stop timer %s %s" file (current-time-string))))))) ;; Create temporary buffers. The number of buffers ;; corresponds to the number of processes; it could be @@ -4559,14 +4644,20 @@ process sentinels. They shall not disturb each other." (set-process-filter proc (lambda (proc string) + (tramp--test-message + "Process filter %s %s %s" proc string (current-time-string)) (with-current-buffer (process-buffer proc) (insert string)) (unless (zerop (length string)) + (dired-uncache (process-get proc 'foo)) (should (file-attributes (process-get proc 'foo)))))) ;; Add process sentinel. (set-process-sentinel proc (lambda (proc _state) + (tramp--test-message + "Process sentinel %s %s" proc (current-time-string)) + (dired-uncache (process-get proc 'foo)) (should-not (file-attributes (process-get proc 'foo))))))) ;; Send a string. Use a random order of the buffers. Mix @@ -4579,7 +4670,10 @@ process sentinels. They shall not disturb each other." (proc (get-buffer-process buf)) (file (process-get proc 'foo)) (count (process-get proc 'bar))) + (tramp--test-message + "Start action %d %s %s" count buf (current-time-string)) ;; Regular operation prior process action. + (dired-uncache file) (if (= count 0) (should-not (file-attributes file)) (should (file-attributes file))) @@ -4588,10 +4682,15 @@ process sentinels. They shall not disturb each other." (accept-process-output proc 0.1 nil 0) ;; Give the watchdog a chance. (read-event nil nil 0.01) + (tramp--test-message + "Continue action %d %s %s" count buf (current-time-string)) ;; Regular operation post process action. + (dired-uncache file) (if (= count 2) (should-not (file-attributes file)) (should (file-attributes file))) + (tramp--test-message + "Stop action %d %s %s" count buf (current-time-string)) (process-put proc 'bar (1+ count)) (unless (process-live-p proc) (setq buffers (delq buf buffers)))))) @@ -4599,6 +4698,7 @@ process sentinels. They shall not disturb each other." ;; Checks. All process output shall exists in the ;; respective buffers. All created files shall be ;; deleted. + (tramp--test-message "Check %s" (current-time-string)) (dolist (buf buffers) (with-current-buffer buf (should (string-equal (format "%s\n" buf) (buffer-string))))) @@ -4613,7 +4713,7 @@ process sentinels. They shall not disturb each other." (ignore-errors (delete-process (get-buffer-process buf))) (ignore-errors (kill-buffer buf))) (ignore-errors (cancel-timer timer)) - (ignore-errors (delete-directory tmp-name 'recursive)))))) + (ignore-errors (delete-directory tmp-name 'recursive))))))) ;; This test is inspired by Bug#29163. (ert-deftest tramp-test42-auto-load () @@ -4629,7 +4729,8 @@ process sentinels. They shall not disturb each other." (shell-command-to-string (format "%s -batch -Q -L %s --eval %s" - (expand-file-name invocation-name invocation-directory) + (shell-quote-argument + (expand-file-name invocation-name invocation-directory)) (mapconcat 'shell-quote-argument load-path " -L ") (shell-quote-argument code))))))) @@ -4661,7 +4762,8 @@ process sentinels. They shall not disturb each other." (shell-command-to-string (format "%s -batch -Q -L %s --eval %s" - (expand-file-name invocation-name invocation-directory) + (shell-quote-argument + (expand-file-name invocation-name invocation-directory)) (mapconcat 'shell-quote-argument load-path " -L ") (shell-quote-argument (format code tm))))))))) @@ -4684,7 +4786,8 @@ process sentinels. They shall not disturb each other." (shell-command-to-string (format "%s -batch -Q -L %s --eval %s" - (expand-file-name invocation-name invocation-directory) + (shell-quote-argument + (expand-file-name invocation-name invocation-directory)) (mapconcat 'shell-quote-argument load-path " -L ") (shell-quote-argument code)))))))) @@ -4711,7 +4814,8 @@ process sentinels. They shall not disturb each other." (shell-command-to-string (format "%s -batch -Q -L %s -l tramp-sh --eval %s" - (expand-file-name invocation-name invocation-directory) + (shell-quote-argument + (expand-file-name invocation-name invocation-directory)) (mapconcat 'shell-quote-argument load-path " -L ") (shell-quote-argument code))))))) @@ -4778,6 +4882,8 @@ Since it unloads Tramp, it shall be the last test to run." ;; * Work on skipped tests. Make a comment, when it is impossible. ;; * Fix `tramp-test05-expand-file-name-relative' in `expand-file-name'. ;; * Fix `tramp-test06-directory-file-name' for `ftp'. +;; * Investigate, why `tramp-test11-copy-file' and `tramp-test12-rename-file' +;; do not work properly for `owncloud'. ;; * Fix `tramp-test29-start-file-process' on MS Windows (`process-send-eof'?). ;; * Fix `tramp-test30-interrupt-process', timeout doesn't work reliably. ;; * Fix Bug#16928 in `tramp-test41-asynchronous-requests'. diff --git a/test/lisp/textmodes/css-mode-tests.el b/test/lisp/textmodes/css-mode-tests.el index 04a13e38240..537a88ec52b 100644 --- a/test/lisp/textmodes/css-mode-tests.el +++ b/test/lisp/textmodes/css-mode-tests.el @@ -244,6 +244,73 @@ (should (member "body" completions)) (should-not (member "article" completions))))) +(ert-deftest css-test-color-to-4-dpc () + (should (equal (css--color-to-4-dpc "#ffffff") + (css--color-to-4-dpc "#fff"))) + (should (equal (css--color-to-4-dpc "#aabbcc") + (css--color-to-4-dpc "#abc"))) + (should (equal (css--color-to-4-dpc "#fab") + "#ffffaaaabbbb")) + (should (equal (css--color-to-4-dpc "#fafbfc") + "#fafafbfbfcfc"))) + +(ert-deftest css-test-named-color-to-hex () + (dolist (item '(("black" "#000000") + ("white" "#ffffff") + ("salmon" "#fa8072"))) + (with-temp-buffer + (css-mode) + (insert (nth 0 item)) + (css--named-color-to-hex) + (should (equal (buffer-string) (nth 1 item)))))) + +(ert-deftest css-test-format-rgba-alpha () + (should (equal (css--format-rgba-alpha 0) "0")) + (should (equal (css--format-rgba-alpha 0.0) "0")) + (should (equal (css--format-rgba-alpha 0.00001) "0")) + (should (equal (css--format-rgba-alpha 1) "1")) + (should (equal (css--format-rgba-alpha 1.0) "1")) + (should (equal (css--format-rgba-alpha 1.00001) "1")) + (should (equal (css--format-rgba-alpha 0.10000) "0.1")) + (should (equal (css--format-rgba-alpha 0.100001) "0.1")) + (should (equal (css--format-rgba-alpha 0.2524334) "0.25"))) + +(ert-deftest css-test-hex-to-rgb () + (dolist (item '(("#000" "rgb(0, 0, 0)") + ("#000000" "rgb(0, 0, 0)") + ("#fff" "rgb(255, 255, 255)") + ("#ffffff" "rgb(255, 255, 255)") + ("#ffffff80" "rgba(255, 255, 255, 0.5)") + ("#fff8" "rgba(255, 255, 255, 0.5)"))) + (with-temp-buffer + (css-mode) + (insert (nth 0 item)) + (css--hex-to-rgb) + (should (equal (buffer-string) (nth 1 item)))))) + +(ert-deftest css-test-rgb-to-named-color-or-hex () + (dolist (item '(("rgb(0, 0, 0)" "black") + ("rgb(255, 255, 255)" "white") + ("rgb(255, 255, 240)" "ivory") + ("rgb(18, 52, 86)" "#123456") + ("rgba(18, 52, 86, 0.5)" "#12345680"))) + (with-temp-buffer + (css-mode) + (insert (nth 0 item)) + (css--rgb-to-named-color-or-hex) + (should (equal (buffer-string) (nth 1 item)))))) + +(ert-deftest css-test-cycle-color-format () + (with-temp-buffer + (css-mode) + (insert "black") + (css-cycle-color-format) + (should (equal (buffer-string) "#000000")) + (css-cycle-color-format) + (should (equal (buffer-string) "rgb(0, 0, 0)")) + (css-cycle-color-format) + (should (equal (buffer-string) "black")))) + (ert-deftest css-mdn-symbol-guessing () (dolist (item '(("@med" "ia" "@media") ("@keyframes " "{" "@keyframes") @@ -301,6 +368,12 @@ (should (equal (css--hex-color "#aabbcc") "#aabbcc")) (should (equal (css--hex-color "#aabbccdd") "#aabbcc"))) +(ert-deftest css-test-hex-alpha () + (should (equal (css--hex-alpha "#abcd") "d")) + (should-not (css--hex-alpha "#abc")) + (should (equal (css--hex-alpha "#aabbccdd") "dd")) + (should-not (css--hex-alpha "#aabbcc"))) + (ert-deftest css-test-named-color () (dolist (text '("@mixin black" "@include black")) (with-temp-buffer diff --git a/test/lisp/xdg-tests.el b/test/lisp/xdg-tests.el index 40f5802854d..ad5e4a48a26 100644 --- a/test/lisp/xdg-tests.el +++ b/test/lisp/xdg-tests.el @@ -65,4 +65,16 @@ (should (equal (xdg-desktop-strings " ") nil)) (should (equal (xdg-desktop-strings "a; ;") '("a" " ")))) +(ert-deftest xdg-mime-associations () + "Test reading MIME associations from files." + (let* ((apps (expand-file-name "mimeapps.list" xdg-tests-data-dir)) + (cache (expand-file-name "mimeinfo.cache" xdg-tests-data-dir)) + (fs (list apps cache))) + (should (equal (xdg-mime-collect-associations "x-test/foo" fs) + '("a.desktop" "b.desktop"))) + (should (equal (xdg-mime-collect-associations "x-test/bar" fs) + '("a.desktop" "c.desktop"))) + (should (equal (xdg-mime-collect-associations "x-test/baz" fs) + '("a.desktop" "b.desktop" "d.desktop"))))) + ;;; xdg-tests.el ends here diff --git a/test/manual/cedet/semantic-ia-utest.el b/test/manual/cedet/semantic-ia-utest.el index 7aae701cc01..938d152925e 100644 --- a/test/manual/cedet/semantic-ia-utest.el +++ b/test/manual/cedet/semantic-ia-utest.el @@ -434,7 +434,7 @@ tag that contains point, and return that." (when (interactive-p) (message "Found %d occurrences of %s in %.2f seconds" Lcount (semantic-tag-name target) - (semantic-elapsed-time start (current-time)))) + (semantic-elapsed-time start nil))) Lcount))) (defun semantic-src-utest-buffer-refs () diff --git a/test/manual/cedet/semantic-tests.el b/test/manual/cedet/semantic-tests.el index c2bc0e1e307..d4be9301be5 100644 --- a/test/manual/cedet/semantic-tests.el +++ b/test/manual/cedet/semantic-tests.el @@ -178,9 +178,8 @@ Optional argument ARG specifies not to use color." "Test `semantic-idle-scheduler-work-parse-neighboring-files' and time it." (interactive) (let ((start (current-time)) - (junk (semantic-idle-scheduler-work-parse-neighboring-files)) - (end (current-time))) - (message "Work took %.2f seconds." (semantic-elapsed-time start end)))) + (junk (semantic-idle-scheduler-work-parse-neighboring-files))) + (message "Work took %.2f seconds." (semantic-elapsed-time start nil)))) ;;; From semantic-lex: @@ -195,10 +194,9 @@ If universal argument ARG, then try the whole buffer." (result (semantic-lex (if arg (point-min) (point)) (point-max) - 100)) - (end (current-time))) + 100))) (message "Elapsed Time: %.2f seconds." - (semantic-elapsed-time start end)) + (semantic-elapsed-time start nil)) (pop-to-buffer "*Lexer Output*") (require 'pp) (erase-buffer) @@ -278,7 +276,7 @@ tag that contains point, and return that." (when (interactive-p) (message "Found %d occurrences of %s in %.2f seconds" Lcount (semantic-tag-name target) - (semantic-elapsed-time start (current-time)))) + (semantic-elapsed-time start nil))) Lcount))) ;;; From bovine-gcc: diff --git a/test/src/data-tests.el b/test/src/data-tests.el index dda1278b6d4..3b88dbca9a2 100644 --- a/test/src/data-tests.el +++ b/test/src/data-tests.el @@ -107,6 +107,21 @@ (should (isnan (min 1.0 0.0e+NaN))) (should (isnan (min 1.0 0.0e+NaN 1.1)))) +(defun data-tests-popcnt (byte) + "Calculate the Hamming weight of BYTE." + (if (< byte 0) + (setq byte (lognot byte))) + (setq byte (- byte (logand (lsh byte -1) #x55555555))) + (setq byte (+ (logand byte #x33333333) (logand (lsh byte -2) #x33333333))) + (lsh (* (logand (+ byte (lsh byte -4)) #x0f0f0f0f) #x01010101) -24)) + +(ert-deftest data-tests-logcount () + (should (cl-loop for n in (number-sequence -255 255) + always (= (logcount n) (data-tests-popcnt n)))) + ;; https://oeis.org/A000120 + (should (= 11 (logcount 9727))) + (should (= 8 (logcount 9999)))) + ;; Bool vector tests. Compactly represent bool vectors as hex ;; strings. diff --git a/test/src/editfns-tests.el b/test/src/editfns-tests.el index b72f37d1f01..69ea6f5cc8f 100644 --- a/test/src/editfns-tests.el +++ b/test/src/editfns-tests.el @@ -136,6 +136,12 @@ (ert-deftest format-c-float () (should-error (format "%c" 0.5))) +;;; Test for Bug#29609. +(ert-deftest format-sharp-0-x () + (should (string-equal (format "%#08x" #x10) "0x000010")) + (should (string-equal (format "%#05X" #x10) "0X010")) + (should (string-equal (format "%#04x" 0) "0000"))) + ;;; Check format-time-string with various TZ settings. ;;; Use only POSIX-compatible TZ values, since the tests should work ;;; even if tzdb is not in use. diff --git a/test/src/fileio-tests.el b/test/src/fileio-tests.el index 5b4db5423fe..5d12685fa19 100644 --- a/test/src/fileio-tests.el +++ b/test/src/fileio-tests.el @@ -29,11 +29,7 @@ (defun fileio-tests--symlink-failure () (let* ((dir (make-temp-file "fileio" t)) - (link (expand-file-name "link" dir)) - (file-name-coding-system (if (and (eq system-type 'darwin) - (featurep 'ucs-normalize)) - 'utf-8-hfs-unix - file-name-coding-system))) + (link (expand-file-name "link" dir))) (unwind-protect (let (failure (char 0)) diff --git a/test/src/json-tests.el b/test/src/json-tests.el new file mode 100644 index 00000000000..47bccbe6f3e --- /dev/null +++ b/test/src/json-tests.el @@ -0,0 +1,180 @@ +;;; json-tests.el --- unit tests for json.c -*- lexical-binding: t; -*- + +;; Copyright (C) 2017-2018 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: + +;; Unit tests for src/json.c. + +;;; Code: + +(require 'cl-lib) +(require 'map) + +(ert-deftest json-serialize/roundtrip () + (skip-unless (fboundp 'json-serialize)) + ;; The noncharacter U+FFFF should be passed through, + ;; cf. https://www.unicode.org/faq/private_use.html#noncharacters. + (let ((lisp [:null :false t 0 123 -456 3.75 "abc\uFFFFαβγ𝔸𝐁𝖢\"\\"]) + (json "[null,false,true,0,123,-456,3.75,\"abc\uFFFFαβγ𝔸𝐁𝖢\\\"\\\\\"]")) + (should (equal (json-serialize lisp) json)) + (with-temp-buffer + (json-insert lisp) + (should (equal (buffer-string) json)) + (should (eobp))) + (should (equal (json-parse-string json) lisp)) + (with-temp-buffer + (insert json) + (goto-char 1) + (should (equal (json-parse-buffer) lisp)) + (should (eobp))))) + +(ert-deftest json-serialize/object () + (skip-unless (fboundp 'json-serialize)) + (let ((table (make-hash-table :test #'equal))) + (puthash "abc" [1 2 t] table) + (puthash "def" :null table) + (should (equal (json-serialize table) + "{\"abc\":[1,2,true],\"def\":null}"))) + (should (equal (json-serialize '((abc . [1 2 t]) (def . :null))) + "{\"abc\":[1,2,true],\"def\":null}")) + (should (equal (json-serialize nil) "{}")) + (should (equal (json-serialize '((abc))) "{\"abc\":{}}")) + (should (equal (json-serialize '((a . 1) (b . 2) (a . 3))) + "{\"a\":1,\"b\":2}")) + (should-error (json-serialize '(abc)) :type 'wrong-type-argument) + (should-error (json-serialize '((a 1))) :type 'wrong-type-argument) + (should-error (json-serialize '((1 . 2))) :type 'wrong-type-argument) + (should-error (json-serialize '((a . 1) . b)) :type 'wrong-type-argument) + (should-error (json-serialize '#1=((a . 1) . #1#)) :type 'circular-list) + (should-error (json-serialize '(#1=(a #1#))))) + +(ert-deftest json-serialize/object-with-duplicate-keys () + (skip-unless (fboundp 'json-serialize)) + (let ((table (make-hash-table :test #'eq))) + (puthash (copy-sequence "abc") [1 2 t] table) + (puthash (copy-sequence "abc") :null table) + (should (equal (hash-table-count table) 2)) + (should-error (json-serialize table) :type 'wrong-type-argument))) + +(ert-deftest json-parse-string/object () + (skip-unless (fboundp 'json-parse-string)) + (let ((input + "{ \"abc\" : [1, 2, true], \"def\" : null, \"abc\" : [9, false] }\n")) + (let ((actual (json-parse-string input))) + (should (hash-table-p actual)) + (should (equal (hash-table-count actual) 2)) + (should (equal (cl-sort (map-pairs actual) #'string< :key #'car) + '(("abc" . [9 :false]) ("def" . :null))))) + (should (equal (json-parse-string input :object-type 'alist) + '((abc . [9 :false]) (def . :null)))))) + +(ert-deftest json-parse-string/string () + (skip-unless (fboundp 'json-parse-string)) + (should-error (json-parse-string "[\"formfeed\f\"]") :type 'json-parse-error) + (should (equal (json-parse-string "[\"foo \\\"bar\\\"\"]") ["foo \"bar\""])) + (should (equal (json-parse-string "[\"abcαβγ\"]") ["abcαβγ"])) + (should (equal (json-parse-string "[\"\\nasd\\u0444\\u044b\\u0432fgh\\t\"]") + ["\nasdфывfgh\t"])) + (should (equal (json-parse-string "[\"\\uD834\\uDD1E\"]") ["\U0001D11E"])) + (should-error (json-parse-string "foo") :type 'json-parse-error) + ;; FIXME: Is this the right behavior? + (should (equal (json-parse-string "[\"\u00C4\xC3\x84\"]") ["\u00C4\u00C4"]))) + +(ert-deftest json-serialize/string () + (skip-unless (fboundp 'json-serialize)) + (should (equal (json-serialize ["foo"]) "[\"foo\"]")) + (should (equal (json-serialize ["a\n\fb"]) "[\"a\\n\\fb\"]")) + (should (equal (json-serialize ["\nasdфыв\u001f\u007ffgh\t"]) + "[\"\\nasdфыв\\u001F\u007ffgh\\t\"]")) + (should (equal (json-serialize ["a\0b"]) "[\"a\\u0000b\"]")) + ;; FIXME: Is this the right behavior? + (should (equal (json-serialize ["\u00C4\xC3\x84"]) "[\"\u00C4\u00C4\"]"))) + +(ert-deftest json-serialize/invalid-unicode () + (skip-unless (fboundp 'json-serialize)) + (should-error (json-serialize ["a\uDBBBb"]) :type 'wrong-type-argument) + (should-error (json-serialize ["u\x110000v"]) :type 'wrong-type-argument) + (should-error (json-serialize ["u\x3FFFFFv"]) :type 'wrong-type-argument) + (should-error (json-serialize ["u\xCCv"]) :type 'wrong-type-argument) + (should-error (json-serialize ["u\u00C4\xCCv"]) :type 'wrong-type-argument)) + +(ert-deftest json-parse-string/null () + (skip-unless (fboundp 'json-parse-string)) + (should-error (json-parse-string "\x00") :type 'wrong-type-argument) + ;; FIXME: Reconsider whether this is the right behavior. + (should-error (json-parse-string "[a\\u0000b]") :type 'json-parse-error)) + +(ert-deftest json-parse-string/invalid-unicode () + "Some examples from +https://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt. +Test with both unibyte and multibyte strings." + (skip-unless (fboundp 'json-parse-string)) + ;; Invalid UTF-8 code unit sequences. + (should-error (json-parse-string "[\"\x80\"]") :type 'json-parse-error) + (should-error (json-parse-string "[\"\u00C4\x80\"]") :type 'json-parse-error) + (should-error (json-parse-string "[\"\xBF\"]") :type 'json-parse-error) + (should-error (json-parse-string "[\"\u00C4\xBF\"]") :type 'json-parse-error) + (should-error (json-parse-string "[\"\xFE\"]") :type 'json-parse-error) + (should-error (json-parse-string "[\"\u00C4\xFE\"]") :type 'json-parse-error) + (should-error (json-parse-string "[\"\xC0\xAF\"]") :type 'json-parse-error) + (should-error (json-parse-string "[\"\u00C4\xC0\xAF\"]") + :type 'json-parse-error) + (should-error (json-parse-string "[\"\u00C4\xC0\x80\"]") + :type 'json-parse-error) + ;; Surrogates. + (should-error (json-parse-string "[\"\uDB7F\"]") + :type 'json-parse-error) + (should-error (json-parse-string "[\"\xED\xAD\xBF\"]") + :type 'json-parse-error) + (should-error (json-parse-string "[\"\u00C4\xED\xAD\xBF\"]") + :type 'json-parse-error) + (should-error (json-parse-string "[\"\uDB7F\uDFFF\"]") + :type 'json-parse-error) + (should-error (json-parse-string "[\"\xED\xAD\xBF\xED\xBF\xBF\"]") + :type 'json-parse-error) + (should-error (json-parse-string "[\"\u00C4\xED\xAD\xBF\xED\xBF\xBF\"]") + :type 'json-parse-error)) + +(ert-deftest json-parse-string/incomplete () + (skip-unless (fboundp 'json-parse-string)) + (should-error (json-parse-string "[123") :type 'json-end-of-file)) + +(ert-deftest json-parse-string/trailing () + (skip-unless (fboundp 'json-parse-string)) + (should-error (json-parse-string "[123] [456]") :type 'json-trailing-content)) + +(ert-deftest json-parse-buffer/incomplete () + (skip-unless (fboundp 'json-parse-buffer)) + (with-temp-buffer + (insert "[123") + (goto-char 1) + (should-error (json-parse-buffer) :type 'json-end-of-file) + (should (bobp)))) + +(ert-deftest json-parse-buffer/trailing () + (skip-unless (fboundp 'json-parse-buffer)) + (with-temp-buffer + (insert "[123] [456]") + (goto-char 1) + (should (equal (json-parse-buffer) [123])) + (should-not (bobp)) + (should (looking-at-p (rx " [456]" eos))))) + +(provide 'json-tests) +;;; json-tests.el ends here diff --git a/test/src/keyboard-tests.el b/test/src/keyboard-tests.el new file mode 100644 index 00000000000..125dbd09391 --- /dev/null +++ b/test/src/keyboard-tests.el @@ -0,0 +1,36 @@ +;;; keyboard-tests.el --- Tests for keyboard.c -*- lexical-binding: t -*- + +;; Copyright (C) 2017-2018 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) + +(ert-deftest keyboard-unread-command-events () + "Test `unread-command-events'." + (should (equal (progn (push ?\C-a unread-command-events) + (read-event nil nil 1)) + ?\C-a)) + (should (equal (progn (run-with-timer + 1 nil + (lambda () (push '(t . ?\C-b) unread-command-events))) + (read-event nil nil 2)) + ?\C-b))) + +(provide 'keyboard-tests) +;;; keyboard-tests.el ends here diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el index 4fec9286e45..daf53438811 100644 --- a/test/src/lread-tests.el +++ b/test/src/lread-tests.el @@ -173,13 +173,20 @@ literals (Bug#20852)." (should (string-suffix-p "/somelib.el" (caar load-history))))) (ert-deftest lread-tests--old-style-backquotes () - "Check that loading warns about 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) - (should (equal (load file-name nil :nomessage :nosuffix) t)) - (should (equal (lread-tests--last-message) - (concat (format-message "Loading `%s': " file-name) - "old-style backquotes detected!"))))) + (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))) |
