mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-12-22 10:26:20 +00:00
bc511a64f6
Most of this change is to boilerplate commentary such as license URLs. This change was prompted by ftp://ftp.gnu.org's going-away party, planned for November. Change these FTP URLs to https://ftp.gnu.org instead. Make similar changes for URLs to other organizations moving away from FTP. Also, change HTTP to HTTPS for URLs to gnu.org and fsf.org when this works, as this will further help defend against man-in-the-middle attacks (for this part I omitted the MS-DOS and MS-Windows sources and the test tarballs to keep the workload down). HTTPS is not fully working to lists.gnu.org so I left those URLs alone for now.
433 lines
18 KiB
EmacsLisp
433 lines
18 KiB
EmacsLisp
;;; filenotify.el --- watch files for changes on disk -*- lexical-binding:t -*-
|
|
|
|
;; Copyright (C) 2013-2017 Free Software Foundation, Inc.
|
|
|
|
;; Author: Michael Albinus <michael.albinus@gmx.de>
|
|
|
|
;; This file is part of GNU Emacs.
|
|
|
|
;; GNU Emacs is free software: you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; GNU Emacs is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary
|
|
|
|
;; This package is an abstraction layer from the different low-level
|
|
;; file notification packages `inotify', `kqueue', `gfilenotify' and
|
|
;; `w32notify'.
|
|
|
|
;;; Code:
|
|
|
|
(require 'cl-lib)
|
|
(eval-when-compile (require 'subr-x))
|
|
|
|
(defconst file-notify--library
|
|
(cond
|
|
((featurep 'inotify) 'inotify)
|
|
((featurep 'kqueue) 'kqueue)
|
|
((featurep 'gfilenotify) 'gfilenotify)
|
|
((featurep 'w32notify) 'w32notify))
|
|
"Non-nil when Emacs has been compiled with file notification support.
|
|
The value is the name of the low-level file notification package
|
|
to be used for local file systems. Remote file notifications
|
|
could use another implementation.")
|
|
|
|
(cl-defstruct (file-notify--watch
|
|
(:constructor nil)
|
|
(:constructor
|
|
file-notify--watch-make (directory filename callback)))
|
|
;; Watched directory
|
|
directory
|
|
;; Watched relative filename, nil if watching the directory.
|
|
filename
|
|
;; Function to propagate events to
|
|
callback)
|
|
|
|
(defun file-notify--watch-absolute-filename (watch)
|
|
"Return the absolute filename observed by WATCH."
|
|
(if (file-notify--watch-filename watch)
|
|
(expand-file-name
|
|
(file-notify--watch-filename watch)
|
|
(file-notify--watch-directory watch))
|
|
(file-notify--watch-directory watch)))
|
|
|
|
(defvar file-notify-descriptors (make-hash-table :test 'equal)
|
|
"Hash table for registered file notification descriptors.
|
|
A key in this hash table is the descriptor as returned from
|
|
`inotify', `kqueue', `gfilenotify', `w32notify' or a file name
|
|
handler. The value in the hash table is `file-notify--watch'
|
|
struct.")
|
|
|
|
(defun file-notify--rm-descriptor (descriptor)
|
|
"Remove DESCRIPTOR from `file-notify-descriptors'.
|
|
DESCRIPTOR should be an object returned by `file-notify-add-watch'.
|
|
If it is registered in `file-notify-descriptors', a stopped event is sent."
|
|
(when-let* ((watch (gethash descriptor file-notify-descriptors)))
|
|
;; Send `stopped' event.
|
|
(unwind-protect
|
|
(funcall
|
|
(file-notify--watch-callback watch)
|
|
`(,descriptor stopped ,(file-notify--watch-absolute-filename watch)))
|
|
(remhash descriptor file-notify-descriptors))))
|
|
|
|
;; This function is used by `inotify', `kqueue', `gfilenotify' and
|
|
;; `w32notify' events.
|
|
;;;###autoload
|
|
(defun file-notify-handle-event (event)
|
|
"Handle file system monitoring event.
|
|
If EVENT is a filewatch event, call its callback. It has the format
|
|
|
|
(file-notify (DESCRIPTOR ACTIONS FILE [FILE1-OR-COOKIE]) CALLBACK)
|
|
|
|
Otherwise, signal a `file-notify-error'."
|
|
(interactive "e")
|
|
;;(message "file-notify-handle-event %S" event)
|
|
(if (and (consp event)
|
|
(eq (car event) 'file-notify)
|
|
(>= (length event) 3))
|
|
(funcall (nth 2 event) (nth 1 event))
|
|
(signal 'file-notify-error
|
|
(cons "Not a valid file-notify event" event))))
|
|
|
|
;; Needed for `inotify' and `w32notify'. In the latter case, COOKIE is nil.
|
|
(defvar file-notify--pending-event nil
|
|
"A pending file notification event for a future `renamed' action.
|
|
It is a form ((DESCRIPTOR ACTION FILE [FILE1-OR-COOKIE]) CALLBACK).")
|
|
|
|
(defun file-notify--event-watched-file (event)
|
|
"Return file or directory being watched.
|
|
Could be different from the directory watched by the backend library."
|
|
(when-let* ((watch (gethash (car event) file-notify-descriptors)))
|
|
(file-notify--watch-absolute-filename watch)))
|
|
|
|
(defun file-notify--event-file-name (event)
|
|
"Return file name of file notification event, or nil."
|
|
(when-let* ((watch (gethash (car event) file-notify-descriptors)))
|
|
(directory-file-name
|
|
(expand-file-name
|
|
(or (and (stringp (nth 2 event)) (nth 2 event)) "")
|
|
(file-notify--watch-directory watch)))))
|
|
|
|
;; Only `gfilenotify' could return two file names.
|
|
(defun file-notify--event-file1-name (event)
|
|
"Return second file name of file notification event, or nil.
|
|
This is available in case a file has been moved."
|
|
(when-let* ((watch (gethash (car event) file-notify-descriptors)))
|
|
(and (stringp (nth 3 event))
|
|
(directory-file-name
|
|
(expand-file-name
|
|
(nth 3 event) (file-notify--watch-directory watch))))))
|
|
|
|
;; Cookies are offered by `inotify' only.
|
|
(defun file-notify--event-cookie (event)
|
|
"Return cookie of file notification event, or nil.
|
|
This is available in case a file has been moved."
|
|
(nth 3 event))
|
|
|
|
;; The callback function used to map between specific flags of the
|
|
;; respective file notifications, and the ones we return.
|
|
(defun file-notify-callback (event)
|
|
"Handle an EVENT returned from file notification.
|
|
EVENT is the cadr of the event in `file-notify-handle-event'
|
|
\(DESCRIPTOR ACTIONS FILE [FILE1-OR-COOKIE])."
|
|
(let* ((desc (car event))
|
|
(watch (gethash desc file-notify-descriptors))
|
|
(actions (nth 1 event))
|
|
(file (file-notify--event-file-name event))
|
|
file1 pending-event stopped)
|
|
|
|
;; Make actions a list.
|
|
(unless (consp actions) (setq actions (cons actions nil)))
|
|
|
|
(when watch
|
|
;; Loop over actions. In fact, more than one action happens only
|
|
;; for `inotify' and `kqueue'.
|
|
(while actions
|
|
(let ((action (pop actions)))
|
|
;; Send pending event, if it doesn't match.
|
|
(when (and file-notify--pending-event
|
|
;; The cookie doesn't match.
|
|
(not (equal (file-notify--event-cookie
|
|
(car file-notify--pending-event))
|
|
(file-notify--event-cookie event)))
|
|
(or
|
|
;; inotify.
|
|
(and (eq (nth 1 (car file-notify--pending-event))
|
|
'moved-from)
|
|
(not (eq action 'moved-to)))
|
|
;; w32notify.
|
|
(and (eq (nth 1 (car file-notify--pending-event))
|
|
'renamed-from)
|
|
(not (eq action 'renamed-to)))))
|
|
(setq pending-event file-notify--pending-event
|
|
file-notify--pending-event nil)
|
|
(setcar (cdar pending-event) 'deleted))
|
|
|
|
;; Map action. We ignore all events which cannot be mapped.
|
|
(setq action
|
|
(cond
|
|
((memq action
|
|
'(attribute-changed changed created deleted renamed))
|
|
action)
|
|
((memq action '(moved rename))
|
|
;; The kqueue rename event does not return file1 in
|
|
;; case a file monitor is established.
|
|
(if (setq file1 (file-notify--event-file1-name event))
|
|
'renamed 'deleted))
|
|
((eq action 'ignored)
|
|
(setq stopped t actions nil))
|
|
((memq action '(attrib link)) 'attribute-changed)
|
|
((memq action '(create added)) 'created)
|
|
((memq action '(modify modified write)) 'changed)
|
|
((memq action '(delete delete-self move-self removed))
|
|
'deleted)
|
|
;; Make the event pending.
|
|
((memq action '(moved-from renamed-from))
|
|
(setq file-notify--pending-event
|
|
`((,desc ,action ,file
|
|
,(file-notify--event-cookie event))
|
|
,(file-notify--watch-callback watch)))
|
|
nil)
|
|
;; Look for pending event.
|
|
((memq action '(moved-to renamed-to))
|
|
(if (null file-notify--pending-event)
|
|
'created
|
|
(setq file1 file
|
|
file (file-notify--event-file-name
|
|
(car file-notify--pending-event)))
|
|
;; If the source is handled by another watch, we
|
|
;; must fire the rename event there as well.
|
|
(unless (equal desc (caar file-notify--pending-event))
|
|
(setq pending-event
|
|
`((,(caar file-notify--pending-event)
|
|
renamed ,file ,file1)
|
|
,(cadr file-notify--pending-event))))
|
|
(setq file-notify--pending-event nil)
|
|
'renamed))))
|
|
|
|
;; Apply pending callback.
|
|
(when pending-event
|
|
(funcall (cadr pending-event) (car pending-event))
|
|
(setq pending-event nil))
|
|
|
|
;; Apply callback.
|
|
(when (and action
|
|
(or
|
|
;; If there is no relative file name for that
|
|
;; watch, we watch the whole directory.
|
|
(null (file-notify--watch-filename watch))
|
|
;; File matches.
|
|
(string-equal
|
|
(file-notify--watch-filename watch)
|
|
(file-name-nondirectory file))
|
|
;; Directory matches.
|
|
(string-equal
|
|
(file-name-nondirectory file)
|
|
(file-name-nondirectory
|
|
(file-notify--watch-directory watch)))
|
|
;; File1 matches.
|
|
(and (stringp file1)
|
|
(string-equal
|
|
(file-notify--watch-filename watch)
|
|
(file-name-nondirectory file1)))))
|
|
;;(message
|
|
;;"file-notify-callback %S %S %S %S %S"
|
|
;;desc action file file1 watch)
|
|
(if file1
|
|
(funcall (file-notify--watch-callback watch)
|
|
`(,desc ,action ,file ,file1))
|
|
(funcall (file-notify--watch-callback watch)
|
|
`(,desc ,action ,file))))
|
|
|
|
;; Send `stopped' event.
|
|
(when (or stopped
|
|
(and (memq action '(deleted renamed))
|
|
;; Not, when a file is backed up.
|
|
(not (and (stringp file1) (backup-file-name-p file1)))
|
|
;; Watched file or directory is concerned.
|
|
(string-equal
|
|
file (file-notify--event-watched-file event))))
|
|
(file-notify-rm-watch desc)))))))
|
|
|
|
;; `kqueue', `gfilenotify' and `w32notify' return a unique descriptor
|
|
;; for every `file-notify-add-watch', while `inotify' returns a unique
|
|
;; descriptor per inode only.
|
|
(defun file-notify-add-watch (file flags callback)
|
|
"Add a watch for filesystem events pertaining to FILE.
|
|
This arranges for filesystem events pertaining to FILE to be reported
|
|
to Emacs. Use `file-notify-rm-watch' to cancel the watch.
|
|
|
|
The returned value is a descriptor for the added watch. If the
|
|
file cannot be watched for some reason, this function signals a
|
|
`file-notify-error' error.
|
|
|
|
FLAGS is a list of conditions to set what will be watched for. It can
|
|
include the following symbols:
|
|
|
|
`change' -- watch for file changes
|
|
`attribute-change' -- watch for file attributes changes, like
|
|
permissions or modification time
|
|
|
|
If FILE is a directory, `change' watches for file creation or
|
|
deletion in that directory. This does not work recursively.
|
|
|
|
When any event happens, Emacs will call the CALLBACK function passing
|
|
it a single argument EVENT, which is of the form
|
|
|
|
(DESCRIPTOR ACTION FILE [FILE1])
|
|
|
|
DESCRIPTOR is the same object as the one returned by this function.
|
|
ACTION is the description of the event. It could be any one of the
|
|
following:
|
|
|
|
`created' -- FILE was created
|
|
`deleted' -- FILE was deleted
|
|
`changed' -- FILE has changed
|
|
`renamed' -- FILE has been renamed to FILE1
|
|
`attribute-changed' -- a FILE attribute was changed
|
|
`stopped' -- watching FILE has been stopped
|
|
|
|
FILE is the name of the file whose event is being reported."
|
|
;; Check arguments.
|
|
(unless (stringp file)
|
|
(signal 'wrong-type-argument `(,file)))
|
|
(setq file (expand-file-name file))
|
|
(unless (and (consp flags)
|
|
(null (delq 'change (delq 'attribute-change (copy-tree flags)))))
|
|
(signal 'wrong-type-argument `(,flags)))
|
|
(unless (functionp callback)
|
|
(signal 'wrong-type-argument `(,callback)))
|
|
|
|
(let* ((handler (find-file-name-handler file 'file-notify-add-watch))
|
|
(dir (directory-file-name
|
|
(if (file-directory-p file)
|
|
file
|
|
(file-name-directory file))))
|
|
desc func l-flags)
|
|
|
|
(unless (file-directory-p dir)
|
|
(signal 'file-notify-error `("Directory does not exist" ,dir)))
|
|
|
|
(if handler
|
|
;; A file name handler could exist even if there is no local
|
|
;; file notification support.
|
|
(setq desc (funcall handler 'file-notify-add-watch dir flags callback))
|
|
|
|
;; Check, whether Emacs has been compiled with file notification
|
|
;; support.
|
|
(unless file-notify--library
|
|
(signal 'file-notify-error
|
|
'("No file notification package available")))
|
|
|
|
;; Determine low-level function to be called.
|
|
(setq func
|
|
(cond
|
|
((eq file-notify--library 'inotify) 'inotify-add-watch)
|
|
((eq file-notify--library 'kqueue) 'kqueue-add-watch)
|
|
((eq file-notify--library 'gfilenotify) 'gfile-add-watch)
|
|
((eq file-notify--library 'w32notify) 'w32notify-add-watch)))
|
|
|
|
;; Determine respective flags.
|
|
(if (eq file-notify--library 'gfilenotify)
|
|
(setq l-flags (append '(watch-mounts send-moved) flags))
|
|
(when (memq 'change flags)
|
|
(setq
|
|
l-flags
|
|
(cond
|
|
((eq file-notify--library 'inotify)
|
|
'(create delete delete-self modify move-self move))
|
|
((eq file-notify--library 'kqueue)
|
|
'(create delete write extend rename))
|
|
((eq file-notify--library 'w32notify)
|
|
'(file-name directory-name size last-write-time)))))
|
|
(when (memq 'attribute-change flags)
|
|
(push (cond
|
|
((eq file-notify--library 'inotify) 'attrib)
|
|
((eq file-notify--library 'kqueue) 'attrib)
|
|
((eq file-notify--library 'w32notify) 'attributes))
|
|
l-flags)))
|
|
|
|
;; Call low-level function.
|
|
(setq desc (funcall
|
|
;; kqueue does not report file changes in directory
|
|
;; monitor. So we must watch the file itself.
|
|
func (if (eq file-notify--library 'kqueue) file dir)
|
|
l-flags 'file-notify-callback)))
|
|
|
|
;; Modify `file-notify-descriptors'.
|
|
(let ((watch (file-notify--watch-make
|
|
dir
|
|
(unless (file-directory-p file) (file-name-nondirectory file))
|
|
callback)))
|
|
(puthash desc watch file-notify-descriptors))
|
|
;; Return descriptor.
|
|
desc))
|
|
|
|
(defun file-notify-rm-watch (descriptor)
|
|
"Remove an existing watch specified by its DESCRIPTOR.
|
|
DESCRIPTOR should be an object returned by `file-notify-add-watch'."
|
|
(when-let* ((watch (gethash descriptor file-notify-descriptors)))
|
|
(let ((handler (find-file-name-handler
|
|
(file-notify--watch-directory watch)
|
|
'file-notify-rm-watch)))
|
|
(condition-case nil
|
|
(if handler
|
|
;; A file name handler could exist even if there is no
|
|
;; local file notification support.
|
|
(funcall handler 'file-notify-rm-watch descriptor)
|
|
|
|
(funcall
|
|
(cond
|
|
((eq file-notify--library 'inotify) 'inotify-rm-watch)
|
|
((eq file-notify--library 'kqueue) 'kqueue-rm-watch)
|
|
((eq file-notify--library 'gfilenotify) 'gfile-rm-watch)
|
|
((eq file-notify--library 'w32notify) 'w32notify-rm-watch))
|
|
descriptor))
|
|
(file-notify-error nil)))
|
|
;; Modify `file-notify-descriptors'.
|
|
(file-notify--rm-descriptor descriptor)))
|
|
|
|
(defun file-notify-valid-p (descriptor)
|
|
"Check a watch specified by its DESCRIPTOR.
|
|
DESCRIPTOR should be an object returned by `file-notify-add-watch'."
|
|
(when-let* ((watch (gethash descriptor file-notify-descriptors)))
|
|
(let ((handler (find-file-name-handler
|
|
(file-notify--watch-directory watch)
|
|
'file-notify-valid-p)))
|
|
(and (if handler
|
|
;; A file name handler could exist even if there is no
|
|
;; local file notification support.
|
|
(funcall handler 'file-notify-valid-p descriptor)
|
|
(funcall
|
|
(cond
|
|
((eq file-notify--library 'inotify) 'inotify-valid-p)
|
|
((eq file-notify--library 'kqueue) 'kqueue-valid-p)
|
|
((eq file-notify--library 'gfilenotify) 'gfile-valid-p)
|
|
((eq file-notify--library 'w32notify) 'w32notify-valid-p))
|
|
descriptor))
|
|
t))))
|
|
|
|
|
|
;; TODO:
|
|
;; * Watching a /dir/file may receive events for dir.
|
|
;; (This may be the desired behaviour.)
|
|
;; * Watching a file in a already watched directory
|
|
;; If the file is created and *then* a watch is added to that file, the
|
|
;; watch might receive events which occurred prior to it being created,
|
|
;; due to the way events are propagated during idle time. Note: This
|
|
;; may be perfectly acceptable.
|
|
|
|
;; The end:
|
|
(provide 'filenotify)
|
|
|
|
;;; filenotify.el ends here
|