diff --git a/configure.ac b/configure.ac index 286ca5241ad..c3e25544fee 100644 --- a/configure.ac +++ b/configure.ac @@ -3370,7 +3370,7 @@ if test "${with_modules}" != "no"; then else SAVE_LIBS=$LIBS LIBS="$LIBS $LIBMODULES" - AC_CHECK_FUNCS([dlfunc]) + AC_CHECK_FUNCS([dladdr dlfunc]) LIBS=$SAVE_LIBS fi fi @@ -3383,7 +3383,6 @@ if test "${HAVE_MODULES}" = yes; then fi AC_SUBST(MODULES_OBJ) AC_SUBST(LIBMODULES) -AC_CHECK_FUNCS(dladdr) ### Use -lpng if available, unless '--with-png=no'. HAVE_PNG=no diff --git a/doc/misc/emacs-mime.texi b/doc/misc/emacs-mime.texi index b252b116a1c..ae1e09105ba 100644 --- a/doc/misc/emacs-mime.texi +++ b/doc/misc/emacs-mime.texi @@ -412,17 +412,31 @@ information about emacs-w3m}, @code{links}, @code{lynx}, external viewer. You can also specify a function, which will be called with a @acronym{MIME} handle as the argument. -@item mm-inline-text-html-with-images +@item mm-html-inhibit-images +@vindex mm-html-inhibit-images @vindex mm-inline-text-html-with-images -Some @acronym{HTML} mails might have the trick of spammers using -@samp{} tags. It is likely to be intended to verify whether you -have read the mail. You can prevent your personal information from -leaking by setting this option to @code{nil} (which is the default). -For emacs-w3m, you may use the command @kbd{t} on the image anchor to -show an image even if it is @code{nil}.@footnote{The command @kbd{T} -will load all images. If you have set the option -@code{w3m-key-binding} to @code{info}, use @kbd{i} or @kbd{I} -instead.} +If this is non-@code{nil}, inhibit displaying of images inline in the +article body. It is effective to images in @acronym{HTML} articles +rendered when @code{mm-text-html-renderer} (@pxref{Display +Customization}) is @code{shr} or @code{w3m}. In Gnus, this is +overridden by the value of @code{gnus-inhibit-images} (@pxref{Misc +Article, ,Misc Article, gnus, Gnus manual}). + +@item mm-html-blocked-images +@vindex mm-html-blocked-images +External images that have @acronym{URL}s that match this regexp won't +be fetched and displayed. For instance, to block all @acronym{URL}s +that have the string ``ads'' in them, do the following: + +@lisp +(setq mm-html-blocked-images "ads") +@end lisp + +It is effective when @code{mm-text-html-renderer} (@pxref{Display +Customization}) is @code{shr}. In Gnus, this is overridden by the value +of @code{gnus-blocked-images} or the return value of the function that +@code{gnus-blocked-images} is set to (@pxref{HTML, ,HTML, gnus, Gnus +manual}). @item mm-w3m-safe-url-regexp @vindex mm-w3m-safe-url-regexp diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index e6e3e7617ee..fa7cd09123c 100644 --- a/doc/misc/gnus.texi +++ b/doc/misc/gnus.texi @@ -11790,7 +11790,7 @@ renderer. If set to @code{gnus-w3m}, it uses @code{w3m}. @item gnus-blocked-images @vindex gnus-blocked-images External images that have @acronym{URL}s that match this regexp won't -be fetched and displayed. For instance, do block all @acronym{URL}s +be fetched and displayed. For instance, to block all @acronym{URL}s that have the string ``ads'' in them, do the following: @lisp diff --git a/etc/NEWS b/etc/NEWS index 717c6bc89ab..f0a3bec4525 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -359,12 +359,17 @@ as you type. See also the new variable ‘text-quoting-style’. ** New minor mode global-eldoc-mode is enabled by default. --- -** Emacs now supports "bracketed paste mode" when running on a terminal -that supports it. This facility allows Emacs to understand pasted -chunks of text as strings to be inserted, instead of interpreting each -character in the pasted text as actual user input. This results in a -paste experience similar to that under a window system, and significant -performance improvements when pasting large amounts of text. +** Emacs now uses "bracketed paste mode" on text terminals that support it. +Bracketed paste mode causes text terminals to wrap pasted text in special +escape sequences that allow Emacs to tell the difference between text +you type and text you paste from other applications. Emacs then +avoids interpreting each character in the pasted text as it does with +keyboard input, which results in a paste experience similar to that +under a window system, and significant performance improvements when +pasting large amounts of text. + +Bracketed paste mode is disabled by default, so Emacs automatically +enables it at startup if the terminal supports it. +++ ** Emacs now supports the latest version of the UBA. diff --git a/lisp/filenotify.el b/lisp/filenotify.el index faa801ee6e7..66e7fd7a315 100644 --- a/lisp/filenotify.el +++ b/lisp/filenotify.el @@ -242,10 +242,14 @@ EVENT is the cadr of the event in `file-notify-handle-event' (and (memq action '(deleted renamed)) (= (length (cdr registered)) 1) + ;; Not, when a file is backed up. + (not (and (stringp file1) (backup-file-name-p file1))) (or + ;; Watched file or directory is concerned. (string-equal (file-name-nondirectory file) (file-name-nondirectory (car registered))) + ;; File inside a watched directory is concerned. (string-equal (file-name-nondirectory file) (car (cadr registered))))))) diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index f36fdd29d62..238a67f5532 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -2258,8 +2258,7 @@ This only works if the article in question is HTML." (save-restriction (widen) (if (eq mm-text-html-renderer 'w3m) - (let ((mm-inline-text-html-with-images nil)) - (w3m-toggle-inline-images)) + (w3m-toggle-inline-images) (dolist (region (gnus-find-text-property-region (point-min) (point-max) 'image-displayer)) (destructuring-bind (start end function) region @@ -4929,25 +4928,30 @@ General format specifiers can also be used. See Info node (vector (caddr c) (car c) :active t)) gnus-url-button-commands))) -(defmacro gnus-bind-safe-url-regexp (&rest body) - "Bind `mm-w3m-safe-url-regexp' according to `gnus-safe-html-newsgroups'." - `(let ((mm-w3m-safe-url-regexp - (let ((group (if (and (derived-mode-p 'gnus-article-mode) - (gnus-buffer-live-p - gnus-article-current-summary)) - (with-current-buffer gnus-article-current-summary - gnus-newsgroup-name) - gnus-newsgroup-name))) - (if (cond ((not group) - ;; Maybe we're in a mml-preview buffer - ;; and no group is selected. - t) - ((stringp gnus-safe-html-newsgroups) - (string-match gnus-safe-html-newsgroups group)) - ((consp gnus-safe-html-newsgroups) - (member group gnus-safe-html-newsgroups))) - nil - mm-w3m-safe-url-regexp)))) +(defmacro gnus-bind-mm-vars (&rest body) + "Bind some mm-* variables and execute BODY." + `(let (mm-html-inhibit-images + mm-html-blocked-images + (mm-w3m-safe-url-regexp mm-w3m-safe-url-regexp)) + (with-current-buffer + (cond ((derived-mode-p 'gnus-article-mode) + (if (gnus-buffer-live-p gnus-article-current-summary) + gnus-article-current-summary + ;; Maybe we're in a mml-preview buffer + ;; and no group is selected. + (current-buffer))) + ((gnus-buffer-live-p gnus-summary-buffer) + gnus-summary-buffer) + (t (current-buffer))) + (setq mm-html-inhibit-images gnus-inhibit-images + mm-html-blocked-images (gnus-blocked-images)) + (when (or (not gnus-newsgroup-name) + (and (stringp gnus-safe-html-newsgroups) + (string-match gnus-safe-html-newsgroups + gnus-newsgroup-name)) + (and (consp gnus-safe-html-newsgroups) + (member gnus-newsgroup-name gnus-safe-html-newsgroups))) + (setq mm-w3m-safe-url-regexp nil))) ,@body)) (defun gnus-mime-button-menu (event prefix) @@ -4975,7 +4979,7 @@ General format specifiers can also be used. See Info node (or (search-forward "\n\n") (goto-char (point-max))) (let ((inhibit-read-only t)) (delete-region (point) (point-max)) - (gnus-bind-safe-url-regexp (mm-display-parts handles))))))) + (gnus-bind-mm-vars (mm-display-parts handles))))))) (defun gnus-article-jump-to-part (n) "Jump to MIME part N." @@ -5514,8 +5518,7 @@ If no internal viewer is available, use an external viewer." (gnus-mime-view-part-as-type nil (lambda (type) (mm-inlinable-p handle type))) (when handle - (gnus-bind-safe-url-regexp - (mm-display-part handle nil t)))))) + (gnus-bind-mm-vars (mm-display-part handle nil t)))))) (defun gnus-mime-action-on-part (&optional action) "Do something with the MIME attachment at (point)." @@ -5745,7 +5748,7 @@ all parts." (mm-inlined-p handle) t) (with-temp-buffer - (gnus-bind-safe-url-regexp + (gnus-bind-mm-vars (setq retval (mm-display-part handle))) (unless (zerop (buffer-size)) (buffer-string)))))) @@ -6106,7 +6109,7 @@ If nil, don't show those extra buttons." (set-buffer gnus-summary-buffer) (error)) gnus-newsgroup-ignored-charsets))) - (gnus-bind-safe-url-regexp (mm-display-part handle t)))) + (gnus-bind-mm-vars (mm-display-part handle t)))) ((and text not-attachment) (mm-display-inline handle))) (goto-char (point-max)) @@ -6236,7 +6239,7 @@ If nil, don't show those extra buttons." (mail-parse-ignored-charsets (with-current-buffer gnus-summary-buffer gnus-newsgroup-ignored-charsets))) - (gnus-bind-safe-url-regexp (mm-display-part preferred)) + (gnus-bind-mm-vars (mm-display-part preferred)) ;; Do highlighting. (save-excursion (save-restriction diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 5551820a2cd..6ee5264a4e7 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -2418,6 +2418,8 @@ With prefix-argument just set Follow-Up, don't cross-post." nil nil '("poster" . 0) (if (boundp 'gnus-group-history) 'gnus-group-history)))) + (when (fboundp 'gnus-group-real-name) + (setq target-group (gnus-group-real-name target-group))) (cond ((not (or (null target-group) ; new subject not empty (zerop (string-width target-group)) (string-match "^[ \t]*$" target-group))) diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index 79fc74a13cf..c6cb6520255 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -145,14 +145,23 @@ nil : use external viewer (default web browser)." (function)) :group 'mime-display) -(defcustom mm-inline-text-html-with-images nil - "If non-nil, Gnus will allow retrieving images in HTML that has tags. -See also the documentation for the `mm-w3m-safe-url-regexp' -variable." - :version "22.1" +(defcustom mm-html-inhibit-images + (if (boundp 'mm-inline-text-html-with-images) + (not (symbol-value 'mm-inline-text-html-with-images)) + t) + "Non-nil means inhibit displaying of images inline in the article body." + :version "25.1" :type 'boolean :group 'mime-display) +(defcustom mm-html-blocked-images "" + "Regexp matching image URLs to be blocked, or nil meaning not to block. +Note that cid images that are embedded in a message won't be blocked." + :version "25.1" + :type '(choice (const :tag "Allow all" nil) + (regexp :tag "Regular expression")) + :group 'mime-display) + (defcustom mm-w3m-safe-url-regexp "\\`cid:" "Regexp matching URLs which are considered to be safe. Some HTML mails might contain a nasty trick used by spammers, using @@ -543,7 +552,7 @@ into \(a 1 b 2 c 3) -The original alist is not modified. See also `destructive-alist-to-plist'." +The original alist is not modified." (let (plist) (while alist (let ((el (car alist))) @@ -1828,14 +1837,11 @@ If RECURSIVE, search recursively." (declare-function shr-insert-document "shr" (dom)) (defvar shr-blocked-images) (defvar shr-use-fonts) -(defvar gnus-inhibit-images) -(autoload 'gnus-blocked-images "gnus-art") (defun mm-shr (handle) ;; Require since we bind its variables. (require 'shr) - (let ((article-buffer (current-buffer)) - (shr-width (if (and (boundp 'shr-use-fonts) + (let ((shr-width (if (and (boundp 'shr-use-fonts) shr-use-fonts) nil fill-column)) @@ -1844,15 +1850,9 @@ If RECURSIVE, search recursively." (when handle (mm-with-part handle (buffer-string)))))) - shr-inhibit-images shr-blocked-images charset char) - (if (and (boundp 'gnus-summary-buffer) - (bufferp gnus-summary-buffer) - (buffer-name gnus-summary-buffer)) - (with-current-buffer gnus-summary-buffer - (setq shr-inhibit-images gnus-inhibit-images - shr-blocked-images (gnus-blocked-images))) - (setq shr-inhibit-images gnus-inhibit-images - shr-blocked-images (gnus-blocked-images))) + (shr-inhibit-images mm-html-inhibit-images) + (shr-blocked-images mm-html-blocked-images) + charset char) (unless handle (setq handle (mm-dissect-buffer t))) (setq charset (mail-content-type-get (mm-handle-type handle) 'charset)) diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el index 9942455300d..8e1e3e782cf 100644 --- a/lisp/gnus/mm-view.el +++ b/lisp/gnus/mm-view.el @@ -141,7 +141,7 @@ (push (cons 'gnus-article-mode 'mm-w3m-cid-retrieve) w3m-cid-retrieve-function-alist)) (setq mm-w3m-setup t)) - (setq w3m-display-inline-images mm-inline-text-html-with-images)) + (setq w3m-display-inline-images (not mm-html-inhibit-images))) (defun mm-w3m-cid-retrieve-1 (url handle) (dolist (elem handle) diff --git a/lisp/gnus/mml-sec.el b/lisp/gnus/mml-sec.el index 48e6384497e..3ac3da0127d 100644 --- a/lisp/gnus/mml-sec.el +++ b/lisp/gnus/mml-sec.el @@ -655,10 +655,10 @@ The passphrase is read and cached." (catch 'break (dolist (uid uids nil) (if (and (stringp (epg-user-id-string uid)) - (equal (car (mail-header-parse-address - (epg-user-id-string uid))) - (car (mail-header-parse-address - recipient))) + (equal (downcase (car (mail-header-parse-address + (epg-user-id-string uid)))) + (downcase (car (mail-header-parse-address + recipient)))) (not (memq (epg-user-id-validity uid) '(revoked expired)))) (throw 'break t)))))) diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index c285befc760..130658cd367 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -1831,7 +1831,9 @@ Return the server's response to the SELECT or EXAMINE command." (let ((open-result t)) (when (and server (not (nnimap-server-opened server))) - (setq open-result (nnimap-open-server server nil no-reconnect))) + (let ((method (gnus-server-to-method server))) + (setq open-result (nnimap-open-server (nth 1 method) (nthcdr 2 method) + no-reconnect)))) (cond ((not open-result) nil) diff --git a/src/alloc.c b/src/alloc.c index 7364d7c4047..81cfdb011dc 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -819,8 +819,10 @@ malloc_unblock_input (void) malloc_probe (size); \ } while (0) +static void *lmalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1)); +static void *lrealloc (void *, size_t); -/* Like malloc but check for no memory and block interrupt input.. */ +/* Like malloc but check for no memory and block interrupt input. */ void * xmalloc (size_t size) @@ -828,7 +830,7 @@ xmalloc (size_t size) void *val; MALLOC_BLOCK_INPUT; - val = malloc (size); + val = lmalloc (size); MALLOC_UNBLOCK_INPUT; if (!val && size) @@ -845,7 +847,7 @@ xzalloc (size_t size) void *val; MALLOC_BLOCK_INPUT; - val = malloc (size); + val = lmalloc (size); MALLOC_UNBLOCK_INPUT; if (!val && size) @@ -866,9 +868,9 @@ xrealloc (void *block, size_t size) /* We must call malloc explicitly when BLOCK is 0, since some reallocs don't do this. */ if (! block) - val = malloc (size); + val = lmalloc (size); else - val = realloc (block, size); + val = lrealloc (block, size); MALLOC_UNBLOCK_INPUT; if (!val && size) @@ -1070,7 +1072,7 @@ lisp_malloc (size_t nbytes, enum mem_type type) allocated_mem_type = type; #endif - val = malloc (nbytes); + val = lmalloc (nbytes); #if ! USE_LSB_TAG /* If the memory just allocated cannot be addressed thru a Lisp @@ -1364,6 +1366,62 @@ lisp_align_free (void *block) MALLOC_UNBLOCK_INPUT; } +#if !defined __GNUC__ && !defined __alignof__ +# define __alignof__(type) alignof (type) +#endif + +/* True if malloc returns a multiple of GCALIGNMENT. In practice this + holds if __alignof__ (max_align_t) is a multiple. Use __alignof__ + if available, as otherwise this check would fail with GCC x86. + This is a macro, not an enum constant, for portability to HP-UX + 10.20 cc and AIX 3.2.5 xlc. */ +#define MALLOC_IS_GC_ALIGNED (__alignof__ (max_align_t) % GCALIGNMENT == 0) + +/* True if P is suitably aligned for SIZE, where Lisp alignment may be + needed if SIZE is Lisp-aligned. */ + +static bool +laligned (void *p, size_t size) +{ + return (MALLOC_IS_GC_ALIGNED || size % GCALIGNMENT != 0 + || (intptr_t) p % GCALIGNMENT == 0); +} + +/* Like malloc and realloc except that if SIZE is Lisp-aligned, make + sure the result is too. */ + +static void * +lmalloc (size_t size) +{ +#if USE_ALIGNED_ALLOC + if (! MALLOC_IS_GC_ALIGNED) + return aligned_alloc (GCALIGNMENT, size); +#endif + + void *p; + while (true) + { + p = malloc (size); + if (laligned (p, size)) + break; + free (p); + } + + eassert ((intptr_t) p % GCALIGNMENT == 0); + return p; +} + +static void * +lrealloc (void *p, size_t size) +{ + do + p = realloc (p, size); + while (! laligned (p, size)); + + eassert ((intptr_t) p % GCALIGNMENT == 0); + return p; +} + /*********************************************************************** Interval Allocation diff --git a/src/lisp.h b/src/lisp.h index 21301702620..f71394e8784 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -67,20 +67,6 @@ DEFINE_GDB_SYMBOL_BEGIN (int, GCTYPEBITS) #define GCTYPEBITS 3 DEFINE_GDB_SYMBOL_END (GCTYPEBITS) -/* The number of bits needed in an EMACS_INT over and above the number - of bits in a pointer. This is 0 on systems where: - 1. We can specify multiple-of-8 alignment on static variables. - 2. We know malloc returns a multiple of 8. */ -#if (defined alignas \ - && (defined GNU_MALLOC || defined DOUG_LEA_MALLOC || defined __GLIBC__ \ - || defined CYGWIN || defined __MINGW32__ \ - || defined DARWIN_OS || defined __FreeBSD__ \ - || defined __sun)) -# define NONPOINTER_BITS 0 -#else -# define NONPOINTER_BITS GCTYPEBITS -#endif - /* EMACS_INT - signed integer wide enough to hold an Emacs value EMACS_INT_MAX - maximum value of EMACS_INT; can be used in #if pI - printf length modifier for EMACS_INT @@ -88,18 +74,16 @@ DEFINE_GDB_SYMBOL_END (GCTYPEBITS) #ifndef EMACS_INT_MAX # if INTPTR_MAX <= 0 # error "INTPTR_MAX misconfigured" -# elif INTPTR_MAX <= INT_MAX >> NONPOINTER_BITS && !defined WIDE_EMACS_INT +# elif INTPTR_MAX <= INT_MAX && !defined WIDE_EMACS_INT typedef int EMACS_INT; typedef unsigned int EMACS_UINT; # define EMACS_INT_MAX INT_MAX # define pI "" -# elif INTPTR_MAX <= LONG_MAX >> NONPOINTER_BITS && !defined WIDE_EMACS_INT +# elif INTPTR_MAX <= LONG_MAX && !defined WIDE_EMACS_INT typedef long int EMACS_INT; typedef unsigned long EMACS_UINT; # define EMACS_INT_MAX LONG_MAX # define pI "l" -/* Check versus LLONG_MAX, not LLONG_MAX >> NONPOINTER_BITS. - In theory this is not safe, but in practice it seems to be OK. */ # elif INTPTR_MAX <= LLONG_MAX typedef long long int EMACS_INT; typedef unsigned long long int EMACS_UINT; diff --git a/test/Makefile.in b/test/Makefile.in index 0034f104598..e651c6caf0b 100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@ -89,10 +89,14 @@ WRITE_LOG = > $@ 2>&1 || { stat=ERROR; cat $@; }; echo $$stat: $@ ## Beware: it approximates 'no-byte-compile', so watch out for false-positives! SELECTOR_DEFAULT = (quote (not (tag :expensive-test))) SELECTOR_EXPENSIVE = nil -ifndef SELECTOR +ifdef SELECTOR +SELECTOR_ACTUAL=$(SELECTOR) +else ifeq ($(MAKECMDGOALS),check) +SELECTOR_ACTUAL=$(SELECTOR_DEFAULT) +else ifeq ($(MAKECMDGOALS),check-maybe) SELECTOR_ACTUAL=$(SELECTOR_DEFAULT) else -SELECTOR_ACTUAL=$(SELECTOR) +SELECTOR_ACTUAL=$(SELECTOR_EXPENSIVE) endif diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el index 5fc4ff8bf42..a8521828c0e 100644 --- a/test/lisp/filenotify-tests.el +++ b/test/lisp/filenotify-tests.el @@ -62,6 +62,10 @@ (defvar file-notify--test-event nil) (defvar file-notify--test-events nil) +(defconst file-notify--test-read-event-timeout 0.02 + "Timeout for `read-event' calls. +It is different for local and remote file notification libraries.") + (defun file-notify--test-timeout () "Timeout to wait for arriving events, in seconds." (cond @@ -74,19 +78,20 @@ "Cleanup after a test." (file-notify-rm-watch file-notify--test-desc) - (when (and file-notify--test-tmpfile - (file-exists-p file-notify--test-tmpfile)) + (ignore-errors + (delete-file (file-newest-backup file-notify--test-tmpfile))) + (ignore-errors (if (file-directory-p file-notify--test-tmpfile) (delete-directory file-notify--test-tmpfile 'recursive) (delete-file file-notify--test-tmpfile))) - (when (and file-notify--test-tmpfile1 - (file-exists-p file-notify--test-tmpfile1)) + (ignore-errors (if (file-directory-p file-notify--test-tmpfile1) (delete-directory file-notify--test-tmpfile1 'recursive) (delete-file file-notify--test-tmpfile1))) - (when (file-remote-p temporary-file-directory) - (tramp-cleanup-connection - (tramp-dissect-file-name temporary-file-directory) nil 'keep-password)) + (ignore-errors + (when (file-remote-p temporary-file-directory) + (tramp-cleanup-connection + (tramp-dissect-file-name temporary-file-directory) nil 'keep-password))) (setq file-notify--test-tmpfile nil file-notify--test-tmpfile1 nil @@ -155,6 +160,7 @@ remote host, or nil." :tags '(:expensive-test) (let* ((temporary-file-directory file-notify-test-remote-temporary-file-directory) + (file-notify--test-read-event-timeout 0.1) (ert-test (ert-get-test ',test))) (skip-unless (file-notify--test-remote-enabled)) (tramp-cleanup-connection @@ -285,7 +291,27 @@ and the event to `file-notify--test-events'." TIMEOUT is the maximum time to wait for, in seconds." `(with-timeout (,timeout (ignore)) (while (null ,until) - (read-event nil nil 0.1)))) + (read-event nil nil file-notify--test-read-event-timeout)))) + +(defun file-notify--test-with-events-check (events) + "Check whether received events match one of the EVENTS alternatives." + (let (result) + (dolist (elt events result) + (setq result + (or result + (equal elt (mapcar #'cadr file-notify--test-events))))))) + +(defun file-notify--test-with-events-explainer (events) + "Explain why `file-notify--test-with-events-check' fails." + (if (null (cdr events)) + (format "Received events `%s' do not match expected events `%s'" + (mapcar #'cadr file-notify--test-events) (car events)) + (format + "Received events `%s' do not match any sequence of expected events `%s'" + (mapcar #'cadr file-notify--test-events) events))) + +(put 'file-notify--test-with-events-check 'ert-explainer + 'file-notify--test-with-events-explainer) (defmacro file-notify--test-with-events (events &rest body) "Run BODY collecting events and then compare with EVENTS. @@ -297,7 +323,7 @@ longer than timeout seconds for the events to be delivered." `(let* ((,outer file-notify--test-events) (events (if (consp (car ,events)) ,events (list ,events))) (max-length (apply 'max (mapcar 'length events))) - create-lockfiles result) + create-lockfiles) ;; Flush pending events. (file-notify--wait-for-events (file-notify--test-timeout) @@ -309,11 +335,7 @@ longer than timeout seconds for the events to be delivered." (* (ceiling max-length 100) (file-notify--test-timeout)) (= max-length (length file-notify--test-events))) ;; One of the possible results shall match. - (should - (dolist (elt events result) - (setq result - (or result - (equal elt (mapcar #'cadr file-notify--test-events)))))) + (should (file-notify--test-with-events-check events)) (setq ,outer (append ,outer file-notify--test-events))) (setq file-notify--test-events ,outer)))) @@ -342,7 +364,7 @@ longer than timeout seconds for the events to be delivered." (t '(created changed deleted stopped))) (write-region "another text" nil file-notify--test-tmpfile nil 'no-message) - (read-event nil nil 0.1) + (read-event nil nil file-notify--test-read-event-timeout) (delete-file file-notify--test-tmpfile)) ;; `file-notify-rm-watch' fires the `stopped' event. Suppress it. (let (file-notify--test-events) @@ -371,10 +393,10 @@ longer than timeout seconds for the events to be delivered." '((changed deleted stopped) (changed changed deleted stopped))) (t '(changed changed deleted stopped))) - (read-event nil nil 0.1) + (read-event nil nil file-notify--test-read-event-timeout) (write-region "another text" nil file-notify--test-tmpfile nil 'no-message) - (read-event nil nil 0.1) + (read-event nil nil file-notify--test-read-event-timeout) (delete-file file-notify--test-tmpfile)) ;; `file-notify-rm-watch' fires the `stopped' event. Suppress it. (let (file-notify--test-events) @@ -405,10 +427,10 @@ longer than timeout seconds for the events to be delivered." ((string-equal (file-notify--test-library) "kqueue") '(created changed deleted stopped)) (t '(created changed deleted deleted stopped))) - (read-event nil nil 0.1) + (read-event nil nil file-notify--test-read-event-timeout) (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) - (read-event nil nil 0.1) + (read-event nil nil file-notify--test-read-event-timeout) (delete-directory temporary-file-directory 'recursive)) ;; `file-notify-rm-watch' fires the `stopped' event. Suppress it. (let (file-notify--test-events) @@ -440,17 +462,17 @@ longer than timeout seconds for the events to be delivered." '(created changed created changed deleted stopped)) (t '(created changed created changed deleted deleted deleted stopped))) - (read-event nil nil 0.1) + (read-event nil nil file-notify--test-read-event-timeout) (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) - (read-event nil nil 0.1) + (read-event nil nil file-notify--test-read-event-timeout) (copy-file file-notify--test-tmpfile file-notify--test-tmpfile1) ;; The next two events shall not be visible. - (read-event nil nil 0.1) + (read-event nil nil file-notify--test-read-event-timeout) (set-file-modes file-notify--test-tmpfile 000) - (read-event nil nil 0.1) + (read-event nil nil file-notify--test-read-event-timeout) (set-file-times file-notify--test-tmpfile '(0 0)) - (read-event nil nil 0.1) + (read-event nil nil file-notify--test-read-event-timeout) (delete-directory temporary-file-directory 'recursive)) ;; `file-notify-rm-watch' fires the `stopped' event. Suppress it. (let (file-notify--test-events) @@ -480,13 +502,13 @@ longer than timeout seconds for the events to be delivered." ((string-equal (file-notify--test-library) "kqueue") '(created changed renamed deleted stopped)) (t '(created changed renamed deleted deleted stopped))) - (read-event nil nil 0.1) + (read-event nil nil file-notify--test-read-event-timeout) (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) - (read-event nil nil 0.1) + (read-event nil nil file-notify--test-read-event-timeout) (rename-file file-notify--test-tmpfile file-notify--test-tmpfile1) ;; After the rename, we won't get events anymore. - (read-event nil nil 0.1) + (read-event nil nil file-notify--test-read-event-timeout) (delete-directory temporary-file-directory 'recursive)) ;; `file-notify-rm-watch' fires the `stopped' event. Suppress it. (let (file-notify--test-events) @@ -514,14 +536,14 @@ longer than timeout seconds for the events to be delivered." (file-remote-p temporary-file-directory)) '(attribute-changed attribute-changed attribute-changed)) (t '(attribute-changed attribute-changed))) - (read-event nil nil 0.1) + (read-event nil nil file-notify--test-read-event-timeout) (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) - (read-event nil nil 0.1) + (read-event nil nil file-notify--test-read-event-timeout) (set-file-modes file-notify--test-tmpfile 000) - (read-event nil nil 0.1) + (read-event nil nil file-notify--test-read-event-timeout) (set-file-times file-notify--test-tmpfile '(0 0)) - (read-event nil nil 0.1) + (read-event nil nil file-notify--test-read-event-timeout) (delete-file file-notify--test-tmpfile)) ;; `file-notify-rm-watch' fires the `stopped' event. Suppress it. (let (file-notify--test-events) @@ -678,10 +700,10 @@ longer than timeout seconds for the events to be delivered." (changed changed deleted stopped))) (t '(changed changed deleted stopped))) (should (file-notify-valid-p file-notify--test-desc)) - (read-event nil nil 0.1) + (read-event nil nil file-notify--test-read-event-timeout) (write-region "another text" nil file-notify--test-tmpfile nil 'no-message) - (read-event nil nil 0.1) + (read-event nil nil file-notify--test-read-event-timeout) (delete-file file-notify--test-tmpfile)) ;; After deleting the file, the descriptor is not valid anymore. (should-not (file-notify-valid-p file-notify--test-desc)) @@ -713,10 +735,10 @@ longer than timeout seconds for the events to be delivered." '(created changed deleted stopped)) (t '(created changed deleted deleted stopped))) (should (file-notify-valid-p file-notify--test-desc)) - (read-event nil nil 0.1) + (read-event nil nil file-notify--test-read-event-timeout) (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) - (read-event nil nil 0.1) + (read-event nil nil file-notify--test-read-event-timeout) (delete-directory temporary-file-directory t)) ;; After deleting the parent directory, the descriptor must ;; not be valid anymore. @@ -814,9 +836,9 @@ longer than timeout seconds for the events to be delivered." (let ((source-file-list source-file-list) (target-file-list target-file-list)) (while (and source-file-list target-file-list) - (read-event nil nil 0.1) + (read-event nil nil file-notify--test-read-event-timeout) (write-region "" nil (pop source-file-list) nil 'no-message) - (read-event nil nil 0.1) + (read-event nil nil file-notify--test-read-event-timeout) (write-region "" nil (pop target-file-list) nil 'no-message)))) (file-notify--test-with-events (cond @@ -829,16 +851,93 @@ longer than timeout seconds for the events to be delivered." (let ((source-file-list source-file-list) (target-file-list target-file-list)) (while (and source-file-list target-file-list) - (rename-file (pop source-file-list) (pop target-file-list) t) - (read-event nil nil 0.02)))) + (read-event nil nil file-notify--test-read-event-timeout) + (rename-file (pop source-file-list) (pop target-file-list) t)))) (file-notify--test-with-events (make-list n 'deleted) (dolist (file target-file-list) - (prog1 (delete-file file) (read-event nil nil 0.02))))) + (read-event nil nil file-notify--test-read-event-timeout) + (delete-file file) file-notify--test-read-event-timeout))) + + ;; Cleanup. (file-notify--test-cleanup))) (file-notify--deftest-remote file-notify-test06-many-events "Check that events are not dropped for remote directories.") +(ert-deftest file-notify-test07-backup () + "Check that backup keeps file notification." + (skip-unless (file-notify--test-local-enabled)) + + (unwind-protect + (progn + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(change) #'file-notify--test-event-handler))) + (should (file-notify-valid-p file-notify--test-desc)) + (file-notify--test-with-events + (cond + ;; For w32notify and in the remote case, there are two + ;; `changed' events. + ((or (string-equal (file-notify--test-library) "w32notify") + (file-remote-p temporary-file-directory)) + '(changed changed)) + (t '(changed))) + ;; There shouldn't be any problem, because the file is kept. + (with-temp-buffer + (let ((buffer-file-name file-notify--test-tmpfile) + (make-backup-files t) + (backup-by-copying t) + (kept-new-versions 1) + (delete-old-versions t)) + (insert "another text") + (save-buffer)))) + ;; After saving the buffer, the descriptor is still valid. + (should (file-notify-valid-p file-notify--test-desc)) + (delete-file file-notify--test-tmpfile)) + + ;; Cleanup. + (file-notify--test-cleanup)) + + (unwind-protect + (progn + ;; It doesn't work for kqueue, because we don't use an + ;; implicit directory monitor. + (unless (string-equal (file-notify--test-library) "kqueue") + (setq file-notify--test-tmpfile (file-notify--test-make-temp-name)) + (write-region + "any text" nil file-notify--test-tmpfile nil 'no-message) + (should + (setq file-notify--test-desc + (file-notify-add-watch + file-notify--test-tmpfile + '(change) #'file-notify--test-event-handler))) + (should (file-notify-valid-p file-notify--test-desc)) + (file-notify--test-with-events '(renamed created changed) + ;; The file is renamed when creating a backup. It shall + ;; still be watched. + (with-temp-buffer + (let ((buffer-file-name file-notify--test-tmpfile) + (make-backup-files t) + (backup-by-copying nil) + (backup-by-copying-when-mismatch nil) + (kept-new-versions 1) + (delete-old-versions t)) + (insert "another text") + (save-buffer)))) + ;; After saving the buffer, the descriptor is still valid. + (should (file-notify-valid-p file-notify--test-desc)) + (delete-file file-notify--test-tmpfile))) + + ;; Cleanup. + (file-notify--test-cleanup))) + +(file-notify--deftest-remote file-notify-test07-backup + "Check that backup keeps file notification for remote files.") + (defun file-notify-test-all (&optional interactive) "Run all tests for \\[file-notify]." (interactive "p")