diff options
| author | Tassilo Horn <tsdh@gnu.org> | 2019-02-20 16:58:57 +0100 |
|---|---|---|
| committer | Tassilo Horn <tsdh@gnu.org> | 2019-02-20 16:58:57 +0100 |
| commit | e5c99a1757c281953257ac2548fb77702af75c86 (patch) | |
| tree | 4820116244ad6650f53208bc792ca248ccc630fb | |
| parent | bfa10b704ebe71c91d5e5eb28e407a02d2d88863 (diff) | |
| parent | ae77728d14e58054bdaee3c6965979947c778208 (diff) | |
| download | emacs-scratch/replace-region-contents.tar.gz | |
Merge branch 'master' into scratch/replace-region-contentsscratch/replace-region-contents
37 files changed, 592 insertions, 226 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index 96473a7086d..9cd39920c23 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -2,7 +2,7 @@ (sentence-end-double-space . t) (fill-column . 70))) (c-mode . ((c-file-style . "GNU") - (c-noise-macro-names . ("UNINIT" "CALLBACK" "ALIGN_STACK")) + (c-noise-macro-names . ("INLINE" "ATTRIBUTE_NO_SANITIZE_UNDEFINED" "UNINIT" "CALLBACK" "ALIGN_STACK")) (electric-quote-comment . nil) (electric-quote-string . nil))) (objc-mode . ((c-file-style . "GNU") diff --git a/configure.ac b/configure.ac index 58579008f3a..c26eb6d1e89 100644 --- a/configure.ac +++ b/configure.ac @@ -4126,7 +4126,7 @@ getrusage get_current_dir_name \ lrand48 random rint trunc \ select getpagesize setlocale newlocale \ getrlimit setrlimit shutdown \ -pthread_sigmask strsignal setitimer \ +pthread_sigmask strsignal setitimer timer_getoverrun \ sendto recvfrom getsockname getifaddrs freeifaddrs \ gai_strerror sync \ getpwent endpwent getgrent endgrent \ @@ -515,27 +515,45 @@ end. ** SQL -*** Installation of 'sql-indent' from ELPA is strongly encouraged. -This package support sophisticated rules for properly indenting SQL -statements. SQL is not like other programming languages like C, Java, -or Python where code is sparse and rules for formatting are fairly -well established. Instead SQL is more like COBOL (from which it came) -and code tends to be very dense and line ending decisions driven by -syntax and line length considerations to make readable code. -Experienced SQL developers may prefer to rely upon existing Emacs -facilities for formatting code but the 'sql-indent' package provides -facilities to aid more casual SQL developers layout queries and -complex expressions. - -*** 'sql-use-indent-support' (default t) enables SQL indention support. +*** SQL Indent Minor Mode + +SQL Mode now supports the ELPA 'sql-indent' package for assisting +sophisticated SQL indenting rules. Note, however, that SQL is not +like other programming languages like C, Java, or Python where code is +sparse and rules for formatting are fairly well established. Instead +SQL is more like COBOL (from which it came) and code tends to be very +dense and line ending decisions driven by syntax and line length +considerations to make readable code. Experienced SQL developers may +prefer to rely upon existing Emacs facilities for formatting code but +the 'sql-indent' package provides facilities to aid more casual SQL +developers layout queries and complex expressions. + +**** 'sql-use-indent-support' (default t) enables SQL indention support. The 'sql-indent' package from ELPA must be installed to get the indentation support in 'sql-mode' and 'sql-interactive-mode'. -*** 'sql-mode-hook' and 'sql-interactive-mode-hook' changed. +**** 'sql-mode-hook' and 'sql-interactive-mode-hook' changed. Both hook variables have had 'sql-indent-enable' added to their -default values. If youhave existing customizations to these variables, +default values. If you have existing customizations to these variables, you should make sure that the new default entry is included. +*** Connection Wallet + +Database passwords can now by stored in NETRC or JSON data files that +may optionally be encrypted. When establishing an interactive session +with the database via 'sql-connect' or a product specific function, +like 'sql-mysql' or 'my-postgres', the password wallet will be +searched for the password. The 'sql-product', 'sql-server', +'sql-database', and the 'sql-username' will be used to identify the +appropriate authorization. This eliminates the discouraged practice of +embedding database passwords in your Emacs initialization. + +See the `auth-source' module for complete documentation on the file +formats. By default, the wallet file is expected to be in the +`user-emacs-directory', named 'sql-wallet' or '.sql-wallet', with +'.json' (JSON) or no (NETRC) suffix. Both file formats can optionally +be encrypted with GPG by adding an additional '.gpg' suffix. + ** Term --- diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el index 2b5b6166ad5..8de01030195 100644 --- a/lisp/arc-mode.el +++ b/lisp/arc-mode.el @@ -967,8 +967,8 @@ using `make-temp-file', and the generated name is returned." ;; Don't re-compress this data just before decompressing it. (jka-compr-inhibit t)) (write-region (point-min) (point-max) tmpfile nil 'quiet)) - (set-buffer-multibyte t) (erase-buffer) + (set-buffer-multibyte t) (insert-file-contents tmpfile)) (delete-file tmpfile))))) diff --git a/lisp/elec-pair.el b/lisp/elec-pair.el index b5ec492930e..3be09d87b4f 100644 --- a/lisp/elec-pair.el +++ b/lisp/elec-pair.el @@ -429,20 +429,25 @@ some list calculations, finally restoring the situation as if nothing happened." (pcase (electric-pair-syntax-info char) (`(,syntax ,pair ,_ ,s-or-c) - (unwind-protect - (progn - (delete-char -1) - (cond ((eq ?\( syntax) - (let* ((pair-data - (electric-pair--balance-info 1 s-or-c)) - (outermost (cdr pair-data))) - (cond ((car outermost) - nil) - (t - (eq (cdr outermost) pair))))) - ((eq syntax ?\") - (electric-pair--unbalanced-strings-p char)))) - (insert char))))) + (catch 'done + ;; FIXME: modify+undo is *very* tricky business. We used to + ;; use `delete-char' followed by `insert', but this changed the + ;; position some markers. The real fix would be to compute the + ;; result without having to modify the buffer at all. + (atomic-change-group + (delete-char -1) + (throw + 'done + (cond ((eq ?\( syntax) + (let* ((pair-data + (electric-pair--balance-info 1 s-or-c)) + (outermost (cdr pair-data))) + (cond ((car outermost) + nil) + (t + (eq (cdr outermost) pair))))) + ((eq syntax ?\") + (electric-pair--unbalanced-strings-p char))))))))) (defun electric-pair-skip-if-helps-balance (char) "Return non-nil if skipping CHAR would benefit parentheses' balance. diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 99b55ad6b72..a2400a0ba37 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -594,10 +594,10 @@ too large if positive or too small if negative)." ;;;###autoload (defun cl-list-length (x) "Return the length of list X. Return nil if list is circular." - (let ((n 0) (fast x) (slow x)) - (while (and (cdr fast) (not (and (eq fast slow) (> n 0)))) - (setq n (+ n 2) fast (cdr (cdr fast)) slow (cdr slow))) - (if fast (if (cdr fast) nil (1+ n)) n))) + (cl-check-type x list) + (condition-case nil + (length x) + (circular-list))) ;;;###autoload (defun cl-tailp (sublist list) diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 3756b52feb8..3a9280fae62 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -365,13 +365,6 @@ SEQ, this is like `mapcar'. With several, it is like the Common Lisp (cl--defalias 'cl-second 'cadr) (cl--defalias 'cl-rest 'cdr) -(defun cl-endp (x) - "Return true if X is the empty list; false if it is a cons. -Signal an error if X is not a list." - (if (listp x) - (null x) - (signal 'wrong-type-argument (list 'listp x 'x)))) - (cl--defalias 'cl-third 'cl-caddr "Return the third element of the list X.") (cl--defalias 'cl-fourth 'cl-cadddr "Return the fourth element of the list X.") diff --git a/lisp/emacs-lisp/cl-seq.el b/lisp/emacs-lisp/cl-seq.el index 31ad8111858..3eb6ea16daf 100644 --- a/lisp/emacs-lisp/cl-seq.el +++ b/lisp/emacs-lisp/cl-seq.el @@ -113,6 +113,13 @@ (defvar cl-key) ;;;###autoload +(defun cl-endp (x) + "Return true if X is the empty list; false if it is a cons. +Signal an error if X is not a list." + (cl-check-type x list) + (null x)) + +;;;###autoload (defun cl-reduce (cl-func cl-seq &rest cl-keys) "Reduce two-argument FUNCTION across SEQ. \nKeywords supported: :start :end :from-end :initial-value :key diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index 07a594fdb56..0cb9a6fa122 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -624,9 +624,7 @@ BODY is executed after moving to the destination location." (when-narrowed (lambda (body) (if (null narrowfun) body - `(let ((was-narrowed - (prog1 (or (< (- (point-max) (point-min)) (buffer-size))) - (widen)))) + `(let ((was-narrowed (prog1 (buffer-narrowed-p) (widen)))) ,body (when was-narrowed (funcall #',narrowfun))))))) (unless name (setq name base-name)) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 876e1ffcebe..697e26b7944 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -62,9 +62,6 @@ ;;; History: ;; -(defconst erc-version-string (format "\C-bERC\C-b (IRC client for Emacs %s)" emacs-version) - "ERC version. This is used by function `erc-version'.") - ;;; Code: (load "erc-loaddefs" nil t) diff --git a/lisp/json.el b/lisp/json.el index 455444cc324..cc0a6fdfd4f 100644 --- a/lisp/json.el +++ b/lisp/json.el @@ -760,7 +760,7 @@ With prefix argument MINIMIZE, minimize it instead." (defun json-pretty-print-buffer-ordered (&optional minimize) "Pretty-print current buffer with object keys ordered. With prefix argument MINIMIZE, minimize it instead." - (interactive) + (interactive "P") (let ((json-encoding-object-sort-predicate 'string<)) (json-pretty-print-buffer minimize))) diff --git a/lisp/mh-e/mh-acros.el b/lisp/mh-e/mh-acros.el index 893564419bc..3bbf509989d 100644 --- a/lisp/mh-e/mh-acros.el +++ b/lisp/mh-e/mh-acros.el @@ -143,6 +143,8 @@ check if variable `transient-mark-mode' is active." ;;;###mh-autoload (defmacro mh-defstruct (name-spec &rest fields) + ;; FIXME: Use `cl-defstruct' instead: shouldn't emit warnings any + ;; more nor depend on run-time CL functions. "Replacement for `defstruct' from the \"cl\" package. The `defstruct' in the \"cl\" library produces compiler warnings, and generates code that uses functions present in \"cl\" at @@ -160,15 +162,17 @@ more details." (constructor (or (and (consp name-spec) (cadr (assoc :constructor (cdr name-spec)))) (intern (format "make-%s" struct-name)))) - (field-names (mapcar #'(lambda (x) (if (atom x) x (car x))) fields)) - (field-init-forms (mapcar #'(lambda (x) (and (consp x) (cadr x))) - fields)) + (fields (mapcar (lambda (x) + (if (atom x) + (list x nil) + (list (car x) (cadr x)))) + fields)) + (field-names (mapcar #'car fields)) (struct (gensym "S")) (x (gensym "X")) (y (gensym "Y"))) `(progn - (defun* ,constructor (&key ,@(mapcar* #'(lambda (x y) (list x y)) - field-names field-init-forms)) + (defun* ,constructor (&key ,@fields) (list (quote ,struct-name) ,@field-names)) (defun ,predicate (arg) (and (consp arg) (eq (car arg) (quote ,struct-name)))) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 7413be42ebd..cc87ffaced5 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -1246,19 +1246,23 @@ scroll the window of possible completions." (setq all (delete-dups all)) (setq last (last all)) - (setq all (if sort-fun (funcall sort-fun all) - ;; Prefer shorter completions, by default. - (sort all (lambda (c1 c2) (< (length c1) (length c2)))))) - ;; Prefer recently used completions and put the default, if - ;; it exists, on top. - (when (minibufferp) - (let ((hist (symbol-value minibuffer-history-variable))) - (setq all (sort all + (cond + (sort-fun + (setq all (funcall sort-fun all))) + (t + ;; Prefer shorter completions, by default. + (setq all (sort all (lambda (c1 c2) (< (length c1) (length c2))))) + (if (minibufferp) + ;; Prefer recently used completions and put the default, if + ;; it exists, on top. + (let ((hist (symbol-value minibuffer-history-variable))) + (setq all + (sort all (lambda (c1 c2) (cond ((equal c1 minibuffer-default) t) ((equal c2 minibuffer-default) nil) (t (> (length (member c1 hist)) - (length (member c2 hist)))))))))) + (length (member c2 hist)))))))))))) ;; Cache the result. This is not just for speed, but also so that ;; repeated calls to minibuffer-force-complete can cycle through ;; all possibilities. diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 4fba4e14f3a..1ba8d6274e5 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -88,7 +88,7 @@ It is used for TCP/IP devices." ;;;###tramp-autoload (defconst tramp-adb-file-name-handler-alist - '((access-file . ignore) + '((access-file . tramp-handle-access-file) (add-name-to-file . tramp-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. ;; `copy-directory' performed by default handler. @@ -1314,7 +1314,10 @@ connection if a previous connection has died for some reason." (current-time-string))))) (tramp-message vec 6 "%s" (mapconcat 'identity (process-command p) " ")) - ;; Wait for initial prompt. + ;; Wait for initial prompt. On some devices, it needs an + ;; initial RET, in order to get it. + (sleep-for 0.1) + (tramp-send-string vec tramp-rsh-end-of-line) (tramp-adb-wait-for-output p 30) (unless (process-live-p p) (tramp-error vec 'file-error "Terminated!")) diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index f975ccfcfa8..db9aec05c20 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -209,7 +209,7 @@ It must be supported by libarchive(3).") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-archive-file-name-handler-alist - '((access-file . ignore) + '((access-file . tramp-archive-handle-access-file) (add-name-to-file . tramp-archive-handle-not-implemented) ;; `byte-compiler-base-file-name' performed by default handler. ;; `copy-directory' performed by default handler. @@ -531,6 +531,10 @@ offered." ;; File name primitives. +(defun tramp-archive-handle-access-file (filename string) + "Like `access-file' for Tramp files." + (access-file (tramp-archive-gvfs-file-name filename) string)) + (defun tramp-archive-handle-copy-file (filename newname &optional ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index bc45acd3ce6..ccbb522184d 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -523,7 +523,7 @@ It has been changed in GVFS 1.14.") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-gvfs-file-name-handler-alist - '((access-file . ignore) + '((access-file . tramp-handle-access-file) (add-name-to-file . tramp-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. ;; `copy-directory' performed by default handler. diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 3a0e002bc67..698296bf550 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -66,7 +66,7 @@ ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-rclone-file-name-handler-alist - '((access-file . ignore) + '((access-file . tramp-handle-access-file) (add-name-to-file . tramp-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. ;; `copy-directory' performed by default handler. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index 404fae9197e..49bc9bfcfc3 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -940,7 +940,7 @@ of command line.") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-sh-file-name-handler-alist - '(;; `access-file' performed by default handler. + '((access-file . tramp-handle-access-file) (add-name-to-file . tramp-sh-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-sh-handle-copy-directory) @@ -2574,6 +2574,9 @@ The method used must be an out-of-band method." "Like `insert-directory' for Tramp files." (setq filename (expand-file-name filename)) (unless switches (setq switches "")) + ;; Check, whether directory is accessible. + (unless wildcard + (access-file filename "Reading directory")) (with-parsed-tramp-file-name filename nil (if (and (featurep 'ls-lisp) (not (symbol-value 'ls-lisp-use-insert-directory-program))) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index fb9073becd0..f57c76c260b 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -214,7 +214,7 @@ See `tramp-actions-before-shell' for more info.") ;; New handlers should be added here. ;;;###tramp-autoload (defconst tramp-smb-file-name-handler-alist - '(;; `access-file' performed by default handler. + '((access-file . tramp-handle-access-file) (add-name-to-file . tramp-smb-handle-add-name-to-file) ;; `byte-compiler-base-file-name' performed by default handler. (copy-directory . tramp-smb-handle-copy-directory) @@ -994,6 +994,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Called from `dired-add-entry'. (setq filename (file-name-as-directory filename)) (setq filename (directory-file-name filename))) + ;; Check, whether directory is accessible. + (unless wildcard + (access-file filename "Reading directory")) (with-parsed-tramp-file-name filename nil (with-tramp-progress-reporter v 0 (format "Opening directory %s" filename) (save-match-data diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 04b0bebabd4..60eb2125030 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -63,7 +63,7 @@ See `tramp-actions-before-shell' for more info.") ;;;###tramp-autoload (defconst tramp-sudoedit-file-name-handler-alist - '((access-file . ignore) + '((access-file . tramp-handle-access-file) (add-name-to-file . tramp-sudoedit-handle-add-name-to-file) (byte-compiler-base-file-name . ignore) ;; `copy-directory' performed by default handler. diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index d000bbe3d65..efe75033f77 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -2310,6 +2310,7 @@ ARGS are the arguments OPERATION has been called with." (defmacro tramp-condition-case-unless-debug (var bodyform &rest handlers) "Like `condition-case-unless-debug' but `tramp-debug-on-error'." + (declare (debug condition-case) (indent 2)) `(let ((debug-on-error tramp-debug-on-error)) (condition-case-unless-debug ,var ,bodyform ,@handlers))) @@ -3060,6 +3061,13 @@ User is always nil." (defvar tramp-handle-write-region-hook nil "Normal hook to be run at the end of `tramp-*-handle-write-region'.") +(defun tramp-handle-access-file (filename string) + "Like `access-file' for Tramp files." + (unless (file-readable-p filename) + (tramp-error + (tramp-dissect-file-name filename) tramp-file-missing + "%s: No such file or directory %s" string filename))) + (defun tramp-handle-add-name-to-file (filename newname &optional ok-if-already-exists) "Like `add-name-to-file' for Tramp files." @@ -3439,6 +3447,9 @@ User is always nil." (when (and (zerop (length (file-name-nondirectory filename))) (not full-directory-p)) (setq switches (concat switches "F"))) + ;; Check, whether directory is accessible. + (unless wildcard + (access-file filename "Reading directory")) (with-parsed-tramp-file-name (expand-file-name filename) nil (with-tramp-progress-reporter v 0 (format "Opening directory %s" filename) (require 'ls-lisp) diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index 071efbc55b5..27ce3029c4a 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el @@ -1732,6 +1732,7 @@ comment at the start of cc-engine.el for more info." (put-text-property beg end 'c-is-sws t) ,@(when (facep 'c-debug-is-sws-face) '((c-debug-add-face beg end 'c-debug-is-sws-face))))) +(def-edebug-spec c-put-is-sws t) (defmacro c-put-in-sws (beg end) ;; This macro does a hidden buffer change. @@ -1739,6 +1740,7 @@ comment at the start of cc-engine.el for more info." (put-text-property beg end 'c-in-sws t) ,@(when (facep 'c-debug-is-sws-face) '((c-debug-add-face beg end 'c-debug-in-sws-face))))) +(def-edebug-spec c-put-in-sws t) (defmacro c-remove-is-sws (beg end) ;; This macro does a hidden buffer change. @@ -1746,6 +1748,7 @@ comment at the start of cc-engine.el for more info." (remove-text-properties beg end '(c-is-sws nil)) ,@(when (facep 'c-debug-is-sws-face) '((c-debug-remove-face beg end 'c-debug-is-sws-face))))) +(def-edebug-spec c-remove-is-sws t) (defmacro c-remove-in-sws (beg end) ;; This macro does a hidden buffer change. @@ -1753,6 +1756,7 @@ comment at the start of cc-engine.el for more info." (remove-text-properties beg end '(c-in-sws nil)) ,@(when (facep 'c-debug-is-sws-face) '((c-debug-remove-face beg end 'c-debug-in-sws-face))))) +(def-edebug-spec c-remove-in-sws t) (defmacro c-remove-is-and-in-sws (beg end) ;; This macro does a hidden buffer change. @@ -1761,6 +1765,7 @@ comment at the start of cc-engine.el for more info." ,@(when (facep 'c-debug-is-sws-face) '((c-debug-remove-face beg end 'c-debug-is-sws-face) (c-debug-remove-face beg end 'c-debug-in-sws-face))))) +(def-edebug-spec c-remove-is-and-in-sws t) ;; The type of literal position `end' is in a `before-change-functions' ;; function - one of `c', `c++', `pound', or nil (but NOT `string'). @@ -1769,12 +1774,14 @@ comment at the start of cc-engine.el for more info." ;; enclosing END, if any, else nil. (defvar c-sws-lit-limits nil) -(defun c-invalidate-sws-region-before (end) - ;; Called from c-before-change. END is the end of the change region, the - ;; standard parameter given to all before-change-functions. +(defun c-invalidate-sws-region-before (beg end) + ;; Called from c-before-change. BEG and END are the bounds of the change + ;; region, the standard parameters given to all before-change-functions. ;; - ;; Note whether END is inside a comment or CPP construct, and if so note its - ;; bounds in `c-sws-lit-limits' and type in `c-sws-lit-type'. + ;; Note whether END is inside a comment, CPP construct, or noise macro, and + ;; if so note its bounds in `c-sws-lit-limits' and type in `c-sws-lit-type'. + (setq c-sws-lit-type nil + c-sws-lit-limits nil) (save-excursion (goto-char end) (let* ((limits (c-literal-limits)) @@ -1787,8 +1794,19 @@ comment at the start of cc-engine.el for more info." (setq c-sws-lit-type 'pound c-sws-lit-limits (cons (point) (progn (c-end-of-macro) (point))))) - (t (setq c-sws-lit-type nil - c-sws-lit-limits nil)))))) + ((progn (skip-syntax-backward "w_") + (looking-at c-noise-macro-name-re)) + (setq c-sws-lit-type 'noise + c-sws-lit-limits (cons (match-beginning 1) (match-end 1)))) + (t)))) + (save-excursion + (goto-char beg) + (skip-syntax-backward "w_") + (when (looking-at c-noise-macro-name-re) + (setq c-sws-lit-type 'noise) + (if (consp c-sws-lit-limits) + (setcar c-sws-lit-limits (match-beginning 1)) + (setq c-sws-lit-limits (cons (match-beginning 1) (match-end 1))))))) (defun c-invalidate-sws-region-after-del (beg end old-len) ;; Text has been deleted, OLD-LEN characters of it starting from position @@ -1797,7 +1815,6 @@ comment at the start of cc-engine.el for more info." ;; deletion deleted or "damaged" its opening delimiter. If so, return the ;; current position of where the construct ended, otherwise return nil. (when c-sws-lit-limits - (setcdr c-sws-lit-limits (- (cdr c-sws-lit-limits) old-len)) (if (and (< beg (+ (car c-sws-lit-limits) 2)) ; A lazy assumption that ; comment delimiters are 2 ; chars long. @@ -1815,9 +1832,9 @@ comment at the start of cc-engine.el for more info." ;; or `c-is-sws' text properties inside this literal. If there are, return ;; the buffer position of the end of the literal, else return nil. (save-excursion + (goto-char end) (let* ((limits (c-literal-limits)) (lit-type (c-literal-type limits))) - (goto-char end) (when (and (not (memq lit-type '(c c++))) (c-beginning-of-macro)) (setq lit-type 'pound @@ -1841,6 +1858,10 @@ comment at the start of cc-engine.el for more info." ;; properties right after they're added. ;; ;; This function does hidden buffer changes. + (when c-sws-lit-limits + (setcar c-sws-lit-limits (min beg (car c-sws-lit-limits))) + (setcdr c-sws-lit-limits + (max end (- (+ (cdr c-sws-lit-limits) (- end beg)) old-len)))) (let ((del-end (and (> old-len 0) (c-invalidate-sws-region-after-del beg end old-len))) @@ -1860,6 +1881,10 @@ comment at the start of cc-engine.el for more info." (when (and (eolp) (not (eobp))) (setq end (1+ (point))))) + (when (eq c-sws-lit-type 'noise) + (setq beg (car c-sws-lit-limits) + end (cdr c-sws-lit-limits))) ; This last setting may be redundant. + (when (and (= beg end) (get-text-property beg 'c-in-sws) (> beg (point-min)) @@ -1879,6 +1904,7 @@ comment at the start of cc-engine.el for more info." (setq end (max (or del-end end) (or ins-end end) + (or (cdr c-sws-lit-limits) end) end)) (c-debug-sws-msg "c-invalidate-sws-region-after [%s..%s]" beg end) @@ -2147,7 +2173,8 @@ comment at the start of cc-engine.el for more info." ;; Try to find a rung position in the simple ws preceding point, so that ;; we can get a cache hit even if the last bit of the simple ws has ;; changed recently. - (setq simple-ws-beg (point)) + (setq simple-ws-beg (or (match-end 1) ; Noise macro + (match-end 0))) ; c-syntactic-ws-end (skip-chars-backward " \t\n\r\f\v") (if (setq rung-is-marked (text-property-any (point) (min (1+ rung-pos) (point-max)) @@ -8672,7 +8699,16 @@ comment at the start of cc-engine.el for more info." (not (and (c-major-mode-is 'c-mode) (not got-prefix) (or (eq context 'top) make-top) - (eq (char-after) ?\))))) + (eq (char-after) ?\)) + (or (memq at-type '(nil maybe)) + (not got-identifier) + (save-excursion + (goto-char after-paren-pos) + (c-forward-syntactic-ws) + ;; Prevent the symbol being recorded as a type. + (let (c-record-type-identifiers) + (not (memq (c-forward-type) + '(nil maybe))))))))) (if (eq (char-after) ?\)) (when (> paren-depth 0) (setq paren-depth (1- paren-depth)) diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el index a2ad07fddb0..6718813b79c 100644 --- a/lisp/progmodes/cc-mode.el +++ b/lisp/progmodes/cc-mode.el @@ -1623,7 +1623,7 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") ;; Are we coalescing two tokens together, e.g. "fo o" -> "foo"? (when (< beg end) (c-unfind-coalesced-tokens beg end)) - (c-invalidate-sws-region-before end) + (c-invalidate-sws-region-before beg end) ;; Are we (potentially) disrupting the syntactic context which ;; makes a type a type? E.g. by inserting stuff after "foo" in ;; "foo bar;", or before "foo" in "typedef foo *bar;"? diff --git a/lisp/progmodes/cc-vars.el b/lisp/progmodes/cc-vars.el index 66960b630e1..89534882672 100644 --- a/lisp/progmodes/cc-vars.el +++ b/lisp/progmodes/cc-vars.el @@ -1649,7 +1649,9 @@ white space either before or after the operator, but not both." ;; Initialize the next two to a regexp which never matches. (defvar c-noise-macro-with-parens-name-re "a\\`") +(make-variable-buffer-local 'c-noise-macro-with-parens-name-re) (defvar c-noise-macro-name-re "a\\`") +(make-variable-buffer-local 'c-noise-macro-name-re) (defcustom c-noise-macro-names nil "A list of names of macros which expand to nothing, or compiler extensions @@ -1664,6 +1666,7 @@ this implicitly by reinitializing C/C++/Objc Mode on any buffer)." :type '(repeat :tag "List of names" string) :group 'c) (put 'c-noise-macro-names 'safe-local-variable #'c-string-list-p) +(make-variable-buffer-local 'c-noise-macro-names) (defcustom c-noise-macro-with-parens-names nil "A list of names of macros \(or compiler extensions like \"__attribute__\") @@ -1673,6 +1676,7 @@ These are recognized by CC Mode only in declarations." :type '(repeat :tag "List of names (possibly empty)" string) :group 'c) (put 'c-noise-macro-with-parens-names 'safe-local-variable #'c-string-list-p) +(make-variable-buffer-local 'c-noise-macro-with-parens-names) (defun c-make-noise-macro-regexps () ;; Convert `c-noise-macro-names' and `c-noise-macro-with-parens-names' into diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index 6ad221295ca..9bae3d86640 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -237,6 +237,7 @@ (require 'custom) (require 'thingatpt) (require 'view) +(eval-when-compile (require 'subr-x)) ; string-empty-p (defvar font-lock-keyword-face) (defvar font-lock-set-defaults) @@ -738,16 +739,131 @@ The package must be available to be loaded and activated." :type 'booleanp :version "27.1") -(defun sql-is-indent-available () - "Check if sql-indent module is available." - (when (locate-library "sql-indent") - (fboundp 'sqlind-minor-mode))) - (defun sql-indent-enable () "Enable `sqlind-minor-mode' if available and requested." - (when (sql-is-indent-available) + (when (fboundp 'sqlind-minor-mode) (sqlind-minor-mode (if sql-use-indent-support +1 -1)))) +;; Secure Password wallet + +(require 'auth-source) + +(defun sql-auth-source-search-wallet (wallet product user server database port) + "Read auth source WALLET to locate the USER secret. +Sets `auth-sources' to WALLET and uses `auth-source-search' to locate the entry. +The DATABASE and SERVER are concatenated with a slash between them as the +host key." + (let* ((auth-sources wallet) + host + secret h-secret sd-secret) + + ;; product + (setq product (symbol-name product)) + + ;; user + (setq user (unless (string-empty-p user) user)) + + ;; port + (setq port + (when (and port (numberp port) (not (zerop port))) + (number-to-string port))) + + ;; server + (setq server (unless (string-empty-p server) server)) + + ;; database + (setq database (unless (string-empty-p database) database)) + + ;; host + (setq host (if server + (if database + (concat server "/" database) + server) + database)) + + ;; Perform search + (dolist (s (auth-source-search :max 1000)) + (when (and + ;; Is PRODUCT specified, in the enty, and they are equal + (if product + (if (plist-member s :product) + (equal (plist-get s :product) product) + t) + t) + ;; Is USER specified, in the entry, and they are equal + (if user + (if (plist-member s :user) + (equal (plist-get s :user) user) + t) + t) + ;; Is PORT specified, in the entry, and they are equal + (if port + (if (plist-member s :port) + (equal (plist-get s :port) port) + t) + t)) + ;; Is HOST specified, in the entry, and they are equal + ;; then the H-SECRET list + (if (and host + (plist-member s :host) + (equal (plist-get s :host) host)) + (push s h-secret) + ;; Are SERVER and DATABASE specified, present, and equal + ;; then the SD-SECRET list + (if (and server + (plist-member s :server) + database + (plist-member s :database) + (equal (plist-get s :server) server) + (equal (plist-get s :database) database)) + (push s sd-secret) + ;; Is SERVER specified, in the entry, and they are equal + ;; then the base SECRET list + (if (and server + (plist-member s :server) + (equal (plist-get s :server) server)) + (push s secret) + ;; Is DATABASE specified, in the entry, and they are equal + ;; then the base SECRET list + (if (and database + (plist-member s :database) + (equal (plist-get s :database) database)) + (push s secret))))))) + (setq secret (or h-secret sd-secret secret)) + + ;; If we found a single secret, return the password + (when (= 1 (length secret)) + (setq secret (car secret)) + (if (plist-member secret :secret) + (plist-get secret :secret) + nil)))) + +(defcustom sql-password-wallet + (let (wallet w) + (dolist (ext '(".json.gpg" ".gpg" ".json" "") wallet) + (unless wallet + (setq w (locate-user-emacs-file (concat "sql-wallet" ext) + (concat ".sql-wallet" ext))) + (when (file-exists-p w) + (setq wallet w))))) + "Identification of the password wallet. +See `sql-password-search-wallet-function' to understand how this value +is used to locate the password wallet." + :type `(plist-get (symbol-plist 'auth-sources) 'custom-type) + :group 'SQL + :version "27.1") + +(defvar sql-password-search-wallet-function #'sql-auth-source-search-wallet + "Function to handle the lookup of the database password. +The specified function will be called as: + (wallet-func WALLET PRODUCT USER SERVER DATABASE PORT) + +It is expected to return either a string containing the password, +a function returning the password, or nil, If you want to support +another format of password file, then implement a different +search wallet function and identify the location of the password +store with `sql-password-wallet'.") + ;; misc customization of sql.el behavior (defcustom sql-electric-stuff nil @@ -804,7 +920,7 @@ Globally should be set to nil; it will be non-nil in `sql-mode', (defvaralias 'sql-pop-to-buffer-after-send-region 'sql-display-sqli-buffer-function) -(defcustom sql-display-sqli-buffer-function 'display-buffer +(defcustom sql-display-sqli-buffer-function #'display-buffer "Function to be called to display a SQLi buffer after `sql-send-*'. When set to a function, it will be called to display the buffer. @@ -2929,7 +3045,7 @@ displayed." ;;; Motion Functions (defun sql-statement-regexp (prod) - (let* ((ansi-stmt (sql-get-product-feature 'ansi :statement)) + (let* ((ansi-stmt (or (sql-get-product-feature 'ansi :statement) "select")) (prod-stmt (sql-get-product-feature prod :statement))) (concat "^\\<" (if prod-stmt @@ -3199,6 +3315,10 @@ symbol `password', for the server if it contains the symbol `database'. The members of WHAT are processed in the order in which they are provided. +If the `sql-password-wallet' is non-nil and WHAT contains the +`password' token, then the `password' token will be pushed to the +end to be sure that all of the values can be fed to the wallet. + Each token may also be a list with the token in the car and a plist of options as the cdr. The following properties are supported: @@ -3210,6 +3330,15 @@ supported: In order to ask the user for username, password and database, call the function like this: (sql-get-login \\='user \\='password \\='database)." + + ;; Push the password to the end if we have a wallet + (when (and sql-password-wallet + (fboundp sql-password-search-wallet-function) + (member 'password what)) + (setq what (append (cl-delete 'password what) + '(password)))) + + ;; Prompt for each parameter (dolist (w what) (let ((plist (cdr-safe w))) (pcase (or (car-safe w) w) @@ -3218,7 +3347,19 @@ function like this: (sql-get-login \\='user \\='password \\='database)." ('password (setq-default sql-password - (read-passwd "Password: " nil (sql-default-value 'sql-password)))) + (if (and sql-password-wallet + (fboundp sql-password-search-wallet-function)) + (let ((password (funcall sql-password-search-wallet-function + sql-password-wallet + sql-product + sql-user + sql-server + sql-database + sql-port))) + (if password + password + (read-passwd "Password: " nil (sql-default-value 'sql-password)))) + (read-passwd "Password: " nil (sql-default-value 'sql-password))))) ('server (sql-get-login-ext 'sql-server "Server: " 'sql-server-history plist)) @@ -3535,8 +3676,8 @@ Allows the suppression of continuation prompts.") ;; Count how many newlines in the string (setq sql-output-newline-count - (apply #'+ (mapcar (lambda (ch) - (if (eq ch ?\n) 1 0)) string))) + (apply #'+ (mapcar (lambda (ch) (if (eq ch ?\n) 1 0)) + string))) ;; Send the string (comint-simple-send proc string))) @@ -4086,7 +4227,7 @@ must tell Emacs. Here's how to do that in your init file: ;; Set syntax and font-face highlighting ;; Catch changes to sql-product and highlight accordingly (sql-set-product (or sql-product 'ansi)) ; Fixes bug#13591 - (add-hook 'hack-local-variables-hook 'sql-highlight-product t t)) + (add-hook 'hack-local-variables-hook #'sql-highlight-product t t)) @@ -4094,7 +4235,7 @@ must tell Emacs. Here's how to do that in your init file: (put 'sql-interactive-mode 'mode-class 'special) (put 'sql-interactive-mode 'custom-mode-group 'SQL) - +;; FIXME: Why not use `define-derived-mode'? (defun sql-interactive-mode () "Major mode to use a SQL interpreter interactively. @@ -4156,13 +4297,15 @@ certain length. \(add-hook \\='sql-interactive-mode-hook (function (lambda () - (setq comint-output-filter-functions \\='comint-truncate-buffer)))) + (setq comint-output-filter-functions #\\='comint-truncate-buffer)))) Here is another example. It will always put point back to the statement you entered, right above the output it created. \(setq comint-output-filter-functions (function (lambda (STR) (comint-show-output))))" + ;; FIXME: The doc above uses `setq' on `comint-output-filter-functions', + ;; whereas hooks should be manipulated with things like `add/remove-hook'. (delay-mode-hooks (comint-mode)) ;; Get the `sql-product' for this interactive session. @@ -4193,7 +4336,8 @@ you entered, right above the output it created. (setq local-abbrev-table sql-mode-abbrev-table) (setq abbrev-all-caps 1) ;; Exiting the process will call sql-stop. - (set-process-sentinel (get-buffer-process (current-buffer)) 'sql-stop) + (let ((proc (get-buffer-process (current-buffer)))) + (when proc (set-process-sentinel proc #'sql-stop))) ;; Save the connection and login params (set (make-local-variable 'sql-user) sql-user) (set (make-local-variable 'sql-database) sql-database) @@ -4211,7 +4355,7 @@ you entered, right above the output it created. (sql-make-alternate-buffer-name)) ;; User stuff. Initialize before the hook. (set (make-local-variable 'sql-prompt-regexp) - (sql-get-product-feature sql-product :prompt-regexp)) + (or (sql-get-product-feature sql-product :prompt-regexp) "^")) (set (make-local-variable 'sql-prompt-length) (sql-get-product-feature sql-product :prompt-length)) (set (make-local-variable 'sql-prompt-cont-regexp) @@ -4219,7 +4363,7 @@ you entered, right above the output it created. (make-local-variable 'sql-output-newline-count) (make-local-variable 'sql-preoutput-hold) (add-hook 'comint-preoutput-filter-functions - 'sql-interactive-remove-continuation-prompt nil t) + #'sql-interactive-remove-continuation-prompt nil t) (make-local-variable 'sql-input-ring-separator) (make-local-variable 'sql-input-ring-file-name) ;; Run the mode hook (along with comint's hooks). @@ -4230,7 +4374,7 @@ you entered, right above the output it created. (concat "\\(" sql-prompt-regexp "\\|" sql-prompt-cont-regexp "\\)") sql-prompt-regexp)) - (setq left-margin sql-prompt-length) + (setq left-margin (or sql-prompt-length 0)) ;; Install input sender (set (make-local-variable 'comint-input-sender) 'sql-input-sender) ;; People wanting a different history file for each @@ -4268,8 +4412,7 @@ Sentinels will always get the two parameters PROCESS and EVENT." "Read a connection name." (let ((completion-ignore-case t)) (completing-read prompt - (mapcar (lambda (c) (car c)) - sql-connection-alist) + (mapcar #'car sql-connection-alist) nil t initial 'sql-connection-history default))) ;;;###autoload @@ -4480,6 +4623,10 @@ the call to \\[sql-product-interactive] with (or sql-default-directory default-directory))) + ;; The password wallet returns a function which supplies the password. + (when (functionp sql-password) + (setq sql-password (funcall sql-password))) + ;; Call the COMINT service (funcall (sql-get-product-feature product :sqli-comint-func) product @@ -4522,7 +4669,8 @@ the call to \\[sql-product-interactive] with (let ((proc (get-buffer-process new-sqli-buffer)) (secs sql-login-delay) (step 0.3)) - (while (and (memq (process-status proc) '(open run)) + (while (and proc + (memq (process-status proc) '(open run)) (or (accept-process-output proc step) (<= 0.0 (setq secs (- secs step)))) (progn (goto-char (point-max)) @@ -5226,8 +5374,7 @@ The default comes from `process-coding-system-alist' and your might try undecided-dos as a coding system. If this doesn't help, Try to set `comint-output-filter-functions' like this: -\(setq comint-output-filter-functions (append comint-output-filter-functions - \\='(comint-strip-ctrl-m))) +\(add-hook 'comint-output-filter-functions #\\='comint-strip-ctrl-m 'append) \(Type \\[describe-mode] in the SQL buffer for a list of commands.)" (interactive "P") diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el index c5382d3f3d1..599da9ac807 100644 --- a/lisp/tar-mode.el +++ b/lisp/tar-mode.el @@ -95,6 +95,7 @@ ;;; Code: (eval-when-compile (require 'cl-lib)) +(require 'arc-mode) (defgroup tar nil "Simple editing of tar files." @@ -852,26 +853,6 @@ actually appear on disk when you save the tar-file's buffer." (goto-char (posn-point (event-end event))) (tar-extract)) -(defun tar--try-jka-compr () - (when (and auto-compression-mode - (jka-compr-get-compression-info buffer-file-name)) - (let* ((basename (file-name-nondirectory buffer-file-name)) - (tmpname (if (string-match ":\\([^:]+\\)\\'" basename) - (match-string 1 basename) basename)) - (tmpfile (make-temp-file (file-name-sans-extension tmpname) - nil - (file-name-extension tmpname 'period)))) - (unwind-protect - (progn - (let ((coding-system-for-write 'no-conversion) - ;; Don't re-compress this data just before decompressing it. - (jka-compr-inhibit t)) - (write-region (point-min) (point-max) tmpfile nil 'quiet)) - (set-buffer-multibyte t) - (erase-buffer) - (insert-file-contents tmpfile)) - (delete-file tmpfile))))) - (defun tar-file-name-handler (op &rest args) "Helper function for `tar-extract'." (or (eq op 'file-exists-p) @@ -951,7 +932,7 @@ actually appear on disk when you save the tar-file's buffer." (setq buffer-file-name new-buffer-file-name) (setq buffer-file-truename (abbreviate-file-name buffer-file-name)) - (tar--try-jka-compr) ;Pretty ugly hack :-( + (archive-try-jka-compr) ;Pretty ugly hack :-( ;; Force buffer-file-coding-system to what ;; decode-coding-region actually used. (set-buffer-file-coding-system last-coding-system-used t) diff --git a/lisp/time.el b/lisp/time.el index d95f708161c..9084217024a 100644 --- a/lisp/time.el +++ b/lisp/time.el @@ -582,7 +582,7 @@ For example, the Unix uptime command format is \"%D, %z%2h:%.2m\"." "Return a string giving the duration of the Emacs initialization." (interactive) (let ((str - (format "%.1f seconds" + (format "%s seconds" (float-time (time-subtract after-init-time before-init-time))))) (if (called-interactively-p 'interactive) diff --git a/lisp/vc/smerge-mode.el b/lisp/vc/smerge-mode.el index 569797e18dd..02cee44a3ae 100644 --- a/lisp/vc/smerge-mode.el +++ b/lisp/vc/smerge-mode.el @@ -1432,6 +1432,40 @@ If no conflict maker is found, turn off `smerge-mode'." (smerge-next)) (error (smerge-auto-leave)))) +(defcustom smerge-change-buffer-confirm t + "If non-nil, request confirmation before moving to another buffer." + :type 'boolean) + +(defun smerge-vc-next-conflict () + "Go to next conflict, possibly in another file. +First tries to go to the next conflict in the current buffer, and if not +found, uses VC to try and find the next file with conflict." + (interactive) + (let ((buffer (current-buffer))) + (condition-case nil + ;; FIXME: Try again from BOB before moving to the next file. + (smerge-next) + (error + (if (and (or smerge-change-buffer-confirm + (and (buffer-modified-p) buffer-file-name)) + (not (or (eq last-command this-command) + (eq ?\r last-command-event)))) ;Called via M-x!? + ;; FIXME: Don't emit this message if `vc-find-conflicted-file' won't + ;; go to another file anyway (because there are no more conflicted + ;; files). + (message (if (buffer-modified-p) + "No more conflicts here. Repeat to save and go to next buffer" + "No more conflicts here. Repeat to go to next buffer")) + (if (and (buffer-modified-p) buffer-file-name) + (save-buffer)) + (vc-find-conflicted-file) + (if (eq buffer (current-buffer)) + ;; Do nothing: presumably `vc-find-conflicted-file' already + ;; emitted a message explaining there aren't any more conflicts. + nil + (goto-char (point-min)) + (smerge-next))))))) + (provide 'smerge-mode) ;;; smerge-mode.el ends here diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el index 42622818fce..7dd7346fe8f 100644 --- a/lisp/vc/vc-hooks.el +++ b/lisp/vc/vc-hooks.el @@ -1,4 +1,4 @@ -;;; vc-hooks.el --- resident support for version-control +;;; vc-hooks.el --- resident support for version-control -*- lexical-binding:t -*- ;; Copyright (C) 1992-1996, 1998-2019 Free Software Foundation, Inc. @@ -173,9 +173,9 @@ Otherwise, not displayed." (make-variable-buffer-local 'vc-mode) (put 'vc-mode 'permanent-local t) -;;; We signal this error when we try to do something a VC backend -;;; doesn't support. Two arguments: the method that's not supported -;;; and the backend +;; We signal this error when we try to do something a VC backend +;; doesn't support. Two arguments: the method that's not supported +;; and the backend (define-error 'vc-not-supported "VC method not implemented for backend") (defun vc-mode (&optional _arg) @@ -243,12 +243,12 @@ if that doesn't exist either, return nil." "Call for BACKEND the implementation of FUNCTION-NAME with the given ARGS. Calls - (apply \\='vc-BACKEND-FUN ARGS) + (apply #\\='vc-BACKEND-FUN ARGS) if vc-BACKEND-FUN exists (after trying to find it in vc-BACKEND.el) and else calls - (apply \\='vc-default-FUN BACKEND ARGS) + (apply #\\='vc-default-FUN BACKEND ARGS) It is usually called via the `vc-call' macro." (let ((f (assoc function-name (get backend 'vc-functions)))) @@ -603,7 +603,7 @@ a regexp for matching all such backup files, regardless of the version." "Delete all existing automatic version backups for FILE." (condition-case nil (mapc - 'delete-file + #'delete-file (directory-files (or (file-name-directory file) default-directory) t (vc-version-backup-file-name file nil nil t))) ;; Don't fail when the directory doesn't exist. @@ -811,7 +811,7 @@ In the latter case, VC mode is deactivated for this buffer." (when buffer-file-name (vc-file-clearprops buffer-file-name) ;; FIXME: Why use a hook? Why pass it buffer-file-name? - (add-hook 'vc-mode-line-hook 'vc-mode-line nil t) + (add-hook 'vc-mode-line-hook #'vc-mode-line nil t) (let (backend) (cond ((setq backend (with-demoted-errors (vc-backend buffer-file-name))) @@ -862,13 +862,13 @@ In the latter case, VC mode is deactivated for this buffer." ))))))))) (add-hook 'find-file-hook #'vc-refresh-state) -(define-obsolete-function-alias 'vc-find-file-hook 'vc-refresh-state "25.1") +(define-obsolete-function-alias 'vc-find-file-hook #'vc-refresh-state "25.1") (defun vc-kill-buffer-hook () "Discard VC info about a file when we kill its buffer." (when buffer-file-name (vc-file-clearprops buffer-file-name))) -(add-hook 'kill-buffer-hook 'vc-kill-buffer-hook) +(add-hook 'kill-buffer-hook #'vc-kill-buffer-hook) ;; Now arrange for (autoloaded) bindings of the main package. ;; Bindings for this have to go in the global map, as we'll often diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index a5c866d7503..aae21ec45a4 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -736,8 +736,7 @@ These are passed to the checkin program by \\[vc-checkin]." (string :tag "Argument String") (repeat :tag "Argument List" :value ("") - string)) - :group 'vc) + string))) (defcustom vc-checkout-switches nil "A string or list of strings specifying extra switches for checkout. @@ -746,8 +745,7 @@ These are passed to the checkout program by \\[vc-checkout]." (string :tag "Argument String") (repeat :tag "Argument List" :value ("") - string)) - :group 'vc) + string))) (defcustom vc-register-switches nil "A string or list of strings; extra switches for registering a file. @@ -756,8 +754,7 @@ These are passed to the checkin program by \\[vc-register]." (string :tag "Argument String") (repeat :tag "Argument List" :value ("") - string)) - :group 'vc) + string))) (defcustom vc-diff-switches nil "A string or list of strings specifying switches for diff under VC. @@ -772,7 +769,6 @@ not specific to any particular backend." (const :tag "None" t) (string :tag "Argument String") (repeat :tag "Argument List" :value ("") string)) - :group 'vc :version "21.1") (defcustom vc-annotate-switches nil @@ -792,15 +788,13 @@ for the backend you use." (const :tag "None" t) (string :tag "Argument String") (repeat :tag "Argument List" :value ("") string)) - :group 'vc :version "25.1") (defcustom vc-log-show-limit 2000 "Limit the number of items shown by the VC log commands. Zero means unlimited. Not all VC backends are able to support this feature." - :type 'integer - :group 'vc) + :type 'integer) (defcustom vc-allow-async-revert nil "Specifies whether the diff during \\[vc-revert] may be asynchronous. @@ -808,7 +802,6 @@ Enabling this option means that you can confirm a revert operation even if the local changes in the file have not been found and displayed yet." :type '(choice (const :tag "No" nil) (const :tag "Yes" t)) - :group 'vc :version "22.1") ;;;###autoload @@ -816,7 +809,6 @@ if the local changes in the file have not been found and displayed yet." "Normal hook (list of functions) run after checking out a file. See `run-hooks'." :type 'hook - :group 'vc :version "21.1") ;;;###autoload @@ -824,26 +816,22 @@ See `run-hooks'." "Normal hook (list of functions) run after commit or file checkin. See also `log-edit-done-hook'." :type 'hook - :options '(log-edit-comment-to-change-log) - :group 'vc) + :options '(log-edit-comment-to-change-log)) ;;;###autoload (defcustom vc-before-checkin-hook nil "Normal hook (list of functions) run before a commit or a file checkin. See `run-hooks'." - :type 'hook - :group 'vc) + :type 'hook) (defcustom vc-retrieve-tag-hook nil "Normal hook (list of functions) run after retrieving a tag." :type 'hook - :group 'vc :version "27.1") (defcustom vc-revert-show-diff t "If non-nil, `vc-revert' shows a `vc-diff' buffer before querying." :type 'boolean - :group 'vc :version "24.1") ;; Header-insertion hair @@ -856,8 +844,7 @@ A %s in the template is replaced with the first string associated with the file's version control type in `vc-BACKEND-header'." :type '(repeat (cons :format "%v" (regexp :tag "File Type") - (string :tag "Header String"))) - :group 'vc) + (string :tag "Header String")))) (defcustom vc-comment-alist '((nroff-mode ".\\\"" "")) @@ -868,13 +855,11 @@ is sensitive to blank lines." :type '(repeat (list :format "%v" (symbol :tag "Mode") (string :tag "Comment Start") - (string :tag "Comment End"))) - :group 'vc) + (string :tag "Comment End")))) (defcustom vc-find-revision-no-save nil "If non-nil, `vc-find-revision' doesn't write the created buffer to file." :type 'boolean - :group 'vc :version "27.1") @@ -940,7 +925,7 @@ use." ;; 'create-repo method. (completing-read (format "%s is not in a version controlled directory.\nUse VC backend: " file) - (mapcar 'symbol-name possible-backends) nil t))) + (mapcar #'symbol-name possible-backends) nil t))) (repo-dir (let ((def-dir (file-name-directory file))) ;; read the directory where to create the @@ -1109,7 +1094,7 @@ BEWARE: this function may change the current buffer." (defun vc-read-backend (prompt) (intern - (completing-read prompt (mapcar 'symbol-name vc-handled-backends) + (completing-read prompt (mapcar #'symbol-name vc-handled-backends) nil 'require-match))) ;; Here's the major entry point. @@ -1367,7 +1352,7 @@ first backend that could register the file is used." (set-buffer-modified-p t)) (vc-buffer-sync))))) (message "Registering %s... " files) - (mapc 'vc-file-clearprops files) + (mapc #'vc-file-clearprops files) (vc-call-backend backend 'register files comment) (mapc (lambda (file) @@ -1569,7 +1554,7 @@ Runs the normal hooks `vc-before-checkin-hook' and `vc-checkin-hook'." ;; not a well-defined concept for filesets. (progn (vc-call-backend backend 'checkin files comment rev) - (mapc 'vc-delete-automatic-version-backups files)) + (mapc #'vc-delete-automatic-version-backups files)) `((vc-state . up-to-date) (vc-checkout-time . ,(file-attribute-modification-time (file-attributes file))) @@ -1727,7 +1712,7 @@ Return t if the buffer had changes, nil otherwise." (error "No revisions of %s exist" file) ;; We regard this as "changed". ;; Diff it against /dev/null. - (apply 'vc-do-command buffer + (apply #'vc-do-command buffer (if async 'async 1) "diff" file (append (vc-switches nil 'diff) '("/dev/null")))))) (setq files (nreverse filtered)))) @@ -2172,6 +2157,7 @@ changes from the current branch." ;; `default-next-file' variable for its default file (M-n), and ;; we could then set it upon mark-resolve, so C-x C-s C-x C-f M-n would ;; automatically offer the next conflicted file. +;;;###autoload (defun vc-find-conflicted-file () "Visit the next conflicted file in the current project." (interactive) @@ -2772,7 +2758,8 @@ If called interactively, read FILE, defaulting to the current buffer's file name if it's under version control." (interactive (list (read-file-name "VC delete file: " nil (when (vc-backend buffer-file-name) - buffer-file-name) t))) + buffer-file-name) + t))) (setq file (expand-file-name file)) (let ((buf (get-file-buffer file)) (backend (vc-backend file))) diff --git a/lisp/window.el b/lisp/window.el index 19f84696e0f..80828bb35c8 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -571,23 +571,25 @@ FRAME. Optional argument MINIBUF t means run FUN on FRAME's minibuffer window even if it isn't active. MINIBUF nil or omitted means run -FUN on FRAME's minibuffer window only if it's active. In both -cases the minibuffer window must be part of FRAME. MINIBUF +FUN on FRAME's minibuffer window only if it's active. In either +case the minibuffer window must be part of FRAME. MINIBUF neither nil nor t means never run FUN on the minibuffer window. This function performs a pre-order, depth-first traversal of the window tree. If FUN changes the window tree, the result is unpredictable." - (setq frame (window-normalize-frame frame)) - (walk-window-tree-1 fun (frame-root-window frame) any) - (when (memq minibuf '(nil t)) + (let ((root (frame-root-window frame)) + (mini (minibuffer-window frame))) + (setq frame (window-normalize-frame frame)) + (unless (eq root mini) + (walk-window-tree-1 fun root any)) ;; Run FUN on FRAME's minibuffer window if requested. - (let ((minibuffer-window (minibuffer-window frame))) - (when (and (window-live-p minibuffer-window) - (eq (window-frame minibuffer-window) frame) - (or (eq minibuf t) - (minibuffer-window-active-p minibuffer-window))) - (funcall fun minibuffer-window))))) + (when (and (window-live-p mini) + (eq (window-frame mini) frame) + (or (eq minibuf t) + (and (not minibuf) + (minibuffer-window-active-p mini)))) + (funcall fun mini)))) (defun walk-window-subtree (fun &optional window any) "Run function FUN on the subtree of windows rooted at WINDOW. @@ -2773,7 +2775,7 @@ shall be resized horizontally." (unless (= (window-new-pixel window) (window-size window horizontal t)) (throw 'apply t))) - frame t) + frame t t) nil)) (defun window-resize (window delta &optional horizontal ignore pixelwise) @@ -3393,7 +3395,8 @@ may happen when the FRAME is not large enough to accommodate it." (when (> delta 0) (if (window-resizable-p window delta horizontal nil t) (window-resize window delta horizontal nil t) - (setq value nil)))))) + (setq value nil))))) + nil nil 'nomini) value)) (defun adjust-window-trailing-edge (window delta &optional horizontal pixelwise) @@ -4171,7 +4174,8 @@ any window whose `no-delete-other-windows' parameter is non-nil." (and (not (window-parameter other 'window-side)) (window-parameter other 'no-delete-other-windows))) - (throw 'tag nil)))) + (throw 'tag nil))) + nil nil 'nomini) t) (setq main (window-main-window frame))) (t @@ -6655,7 +6659,7 @@ split." (unless (or (eq w window) (window-dedicated-p w)) (throw 'done nil))) - frame) + frame nil 'nomini) t))) (not (window-minibuffer-p window)) (let ((split-height-threshold 0)) diff --git a/src/fns.c b/src/fns.c index 95bafae6c4c..d55158e72f1 100644 --- a/src/fns.c +++ b/src/fns.c @@ -91,8 +91,7 @@ See Info node `(elisp)Random Numbers' for more details. */) /* Random data-structure functions. */ -/* Return the length of LIST. Signal an error if LIST is not a proper - list or if the length does not fit into a fixnum or into ptrdiff_t. */ +/* Return LIST's length. Signal an error if LIST is not a proper list. */ ptrdiff_t list_length (Lisp_Object list) diff --git a/src/minibuf.c b/src/minibuf.c index 321fda1ba88..b23e24c4bd9 100644 --- a/src/minibuf.c +++ b/src/minibuf.c @@ -1801,7 +1801,9 @@ If FLAG is nil, invoke `try-completion'; if it is t, invoke else if (EQ (flag, Qlambda)) return Ftest_completion (string, Vbuffer_alist, predicate); else if (EQ (flag, Qmetadata)) - return list2 (Qmetadata, Fcons (Qcategory, Qbuffer)); + return list3 (Qmetadata, + Fcons (Qcategory, Qbuffer), + Fcons (Qcycle_sort_function, Qidentity)); else return Qnil; } @@ -1922,6 +1924,8 @@ syms_of_minibuf (void) DEFSYM (Qactivate_input_method, "activate-input-method"); DEFSYM (Qcase_fold_search, "case-fold-search"); DEFSYM (Qmetadata, "metadata"); + DEFSYM (Qcycle_sort_function, "cycle-sort-function"); + /* A frame parameter. */ DEFSYM (Qminibuffer_exit, "minibuffer-exit"); diff --git a/src/profiler.c b/src/profiler.c index 15a0eef0d3e..2aa5f345740 100644 --- a/src/profiler.c +++ b/src/profiler.c @@ -118,9 +118,8 @@ static void evict_lower_half (log_t *log) { ptrdiff_t size = ASIZE (log->key_and_value) / 2; EMACS_INT median = approximate_median (log, 0, size); - ptrdiff_t i; - for (i = 0; i < size; i++) + for (ptrdiff_t i = 0; i < size; i++) /* Evict not only values smaller but also values equal to the median, so as to make sure we evict something no matter what. */ if (XFIXNUM (HASH_VALUE (log, i)) <= median) @@ -148,17 +147,14 @@ static void evict_lower_half (log_t *log) static void record_backtrace (log_t *log, EMACS_INT count) { - Lisp_Object backtrace; - ptrdiff_t index; - if (log->next_free < 0) /* FIXME: transfer the evicted counts to a special entry rather than dropping them on the floor. */ evict_lower_half (log); - index = log->next_free; + ptrdiff_t index = log->next_free; /* Get a "working memory" vector. */ - backtrace = HASH_KEY (log, index); + Lisp_Object backtrace = HASH_KEY (log, index); get_backtrace (backtrace); { /* We basically do a `gethash+puthash' here, except that we have to be @@ -232,12 +228,6 @@ static EMACS_INT current_sampling_interval; /* Signal handler for sampling profiler. */ -/* timer_getoverrun is not implemented on Cygwin, but the following - seems to be good enough for profiling. */ -#ifdef CYGWIN -#define timer_getoverrun(x) 0 -#endif - static void handle_profiler_signal (int signal) { @@ -252,7 +242,7 @@ handle_profiler_signal (int signal) else { EMACS_INT count = 1; -#ifdef HAVE_ITIMERSPEC +#if defined HAVE_ITIMERSPEC && defined HAVE_TIMER_GETOVERRUN if (profiler_timer_ok) { int overruns = timer_getoverrun (profiler_timer); @@ -274,9 +264,6 @@ deliver_profiler_signal (int signal) static int setup_cpu_timer (Lisp_Object sampling_interval) { - struct sigaction action; - struct itimerval timer; - struct timespec interval; int billion = 1000000000; if (! RANGED_FIXNUMP (1, sampling_interval, @@ -287,8 +274,10 @@ setup_cpu_timer (Lisp_Object sampling_interval) return -1; current_sampling_interval = XFIXNUM (sampling_interval); - interval = make_timespec (current_sampling_interval / billion, - current_sampling_interval % billion); + struct timespec interval + = make_timespec (current_sampling_interval / billion, + current_sampling_interval % billion); + struct sigaction action; emacs_sigaction_init (&action, deliver_profiler_signal); sigaction (SIGPROF, &action, 0); @@ -308,16 +297,15 @@ setup_cpu_timer (Lisp_Object sampling_interval) #endif CLOCK_REALTIME }; - int i; struct sigevent sigev; sigev.sigev_value.sival_ptr = &profiler_timer; sigev.sigev_signo = SIGPROF; sigev.sigev_notify = SIGEV_SIGNAL; - for (i = 0; i < ARRAYELTS (system_clock); i++) + for (int i = 0; i < ARRAYELTS (system_clock); i++) if (timer_create (system_clock[i], &sigev, &profiler_timer) == 0) { - profiler_timer_ok = 1; + profiler_timer_ok = true; break; } } @@ -332,6 +320,7 @@ setup_cpu_timer (Lisp_Object sampling_interval) #endif #ifdef HAVE_SETITIMER + struct itimerval timer; timer.it_value = timer.it_interval = make_timeval (interval); if (setitimer (ITIMER_PROF, &timer, 0) == 0) return SETITIMER_RUNNING; @@ -358,7 +347,7 @@ See also `profiler-log-size' and `profiler-max-stack-depth'. */) } int status = setup_cpu_timer (sampling_interval); - if (status == -1) + if (status < 0) { profiler_cpu_running = NOT_RUNNING; error ("Invalid sampling interval"); @@ -387,8 +376,7 @@ Return non-nil if the profiler was running. */) #ifdef HAVE_ITIMERSPEC case TIMER_SETTIME_RUNNING: { - struct itimerspec disable; - memset (&disable, 0, sizeof disable); + struct itimerspec disable = { 0, }; timer_settime (profiler_timer, 0, &disable, 0); } break; @@ -397,8 +385,7 @@ Return non-nil if the profiler was running. */) #ifdef HAVE_SETITIMER case SETITIMER_RUNNING: { - struct itimerval disable; - memset (&disable, 0, sizeof disable); + struct itimerval disable = { 0, }; setitimer (ITIMER_PROF, &disable, 0); } break; @@ -550,10 +537,10 @@ cmpfn_profiler (struct hash_table_test *t, { if (VECTORP (bt1) && VECTORP (bt2)) { - ptrdiff_t i, l = ASIZE (bt1); + ptrdiff_t l = ASIZE (bt1); if (l != ASIZE (bt2)) return false; - for (i = 0; i < l; i++) + for (ptrdiff_t i = 0; i < l; i++) if (NILP (Ffunction_equal (AREF (bt1, i), AREF (bt2, i)))) return false; return true; @@ -568,8 +555,8 @@ hashfn_profiler (struct hash_table_test *ht, Lisp_Object bt) if (VECTORP (bt)) { EMACS_UINT hash = 0; - ptrdiff_t i, l = ASIZE (bt); - for (i = 0; i < l; i++) + ptrdiff_t l = ASIZE (bt); + for (ptrdiff_t i = 0; i < l; i++) { Lisp_Object f = AREF (bt, i); EMACS_UINT hash1 diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index 1d9de39ae96..9f06ab1000c 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -570,26 +570,35 @@ This checks also `file-name-as-directory', `file-name-directory', (format "\\(.+ %s\\( ->.+\\)?\n\\)\\{%d\\}" (regexp-opt (directory-files tramp-archive-test-archive)) - (length (directory-files tramp-archive-test-archive)))))))) + (length (directory-files tramp-archive-test-archive))))))) + + ;; Check error case. + (with-temp-buffer + (should-error + (insert-directory + (expand-file-name "baz" tramp-archive-test-archive) nil) + :type tramp-file-missing))) ;; 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'." +This tests also `access-file', `file-readable-p' and `file-regular-p'." :tags '(:expensive-test) (skip-unless tramp-archive-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)) + (tmp-name4 (expand-file-name "baz" 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)) + (should-not (access-file tmp-name1 "error")) ;; We do not test inodes and device numbers. (setq attr (file-attributes tmp-name1)) @@ -622,7 +631,13 @@ This tests also `file-readable-p' and `file-regular-p'." (should (file-readable-p tmp-name3)) (should-not (file-regular-p tmp-name3)) (setq attr (file-attributes tmp-name3)) - (should (eq (car attr) t))) + (should (eq (car attr) t)) + (should-not (access-file tmp-name3 "error")) + + ;; Check error case. + (should-error + (access-file tmp-name4 "error") + :type tramp-file-missing)) ;; Cleanup. (tramp-archive-cleanup-hash)))) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index dccef81b7b5..3afe9ad557d 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -2730,7 +2730,14 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (format "\\(.+ %s\\( ->.+\\)?\n\\)\\{%d\\}" (regexp-opt (directory-files tmp-name1)) - (length (directory-files tmp-name1)))))))) + (length (directory-files tmp-name1))))))) + + ;; Check error case. We do not check for the error type, + ;; because ls-lisp returns `file-error', and native Tramp + ;; returns `file-missing'. + (delete-directory tmp-name1 'recursive) + (with-temp-buffer + (should-error (insert-directory tmp-name1 nil)))) ;; Cleanup. (ignore-errors (delete-directory tmp-name1 'recursive)))))) @@ -2856,8 +2863,8 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (ert-deftest tramp-test18-file-attributes () "Check `file-attributes'. -This tests also `file-readable-p', `file-regular-p' and -`file-ownership-preserved-p'." +This tests also `access-file', `file-readable-p', +`file-regular-p' and `file-ownership-preserved-p'." (skip-unless (tramp--test-enabled)) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) @@ -2878,6 +2885,9 @@ This tests also `file-readable-p', `file-regular-p' and attr) (unwind-protect (progn + (should-error + (access-file tmp-name1 "error") + :type tramp-file-missing) ;; `file-ownership-preserved-p' should return t for ;; non-existing files. It is implemented only in tramp-sh.el. (when (tramp--test-sh-p) @@ -2886,6 +2896,7 @@ This tests also `file-readable-p', `file-regular-p' and (should (file-exists-p tmp-name1)) (should (file-readable-p tmp-name1)) (should (file-regular-p tmp-name1)) + (should-not (access-file tmp-name1 "error")) (when (tramp--test-sh-p) (should (file-ownership-preserved-p tmp-name1 'group))) @@ -2910,11 +2921,15 @@ This tests also `file-readable-p', `file-regular-p' and (should (stringp (nth 3 attr))) ;; Gid. (tramp--test-ignore-make-symbolic-link-error + (should-error + (access-file tmp-name2 "error") + :type tramp-file-missing) (when (tramp--test-sh-p) (should (file-ownership-preserved-p tmp-name2 'group))) (make-symbolic-link tmp-name1 tmp-name2) (should (file-exists-p tmp-name2)) (should (file-symlink-p tmp-name2)) + (should-not (access-file tmp-name2 "error")) (when (tramp--test-sh-p) (should (file-ownership-preserved-p tmp-name2 'group))) (setq attr (file-attributes tmp-name2)) @@ -2953,6 +2968,7 @@ This tests also `file-readable-p', `file-regular-p' and (should (file-exists-p tmp-name1)) (should (file-readable-p tmp-name1)) (should-not (file-regular-p tmp-name1)) + (should-not (access-file tmp-name1 "")) (when (tramp--test-sh-p) (should (file-ownership-preserved-p tmp-name1 'group))) (setq attr (file-attributes tmp-name1)) @@ -4113,7 +4129,8 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Like `shell-command-to-string', but for asynchronous processes." (with-temp-buffer (async-shell-command command (current-buffer)) - (with-timeout (10 (tramp--test-timeout-handler)) + (with-timeout + ((if (getenv "EMACS_EMBA_CI") 30 10) (tramp--test-timeout-handler)) (while (accept-process-output (get-buffer-process (current-buffer)) nil nil t))) (buffer-substring-no-properties (point-min) (point-max)))) @@ -5589,8 +5606,8 @@ Since it unloads Tramp, it shall be the last test to run." ;; * Fix `tramp-test06-directory-file-name' for `ftp'. ;; * Investigate, why `tramp-test11-copy-file' and `tramp-test12-rename-file' ;; do not work properly for `nextcloud'. -;; * Fix `tramp-test29-start-file-process' on MS Windows (`process-send-eof'?). -;; * Fix `tramp-test31-interrupt-process', timeout doesn't work reliably. +;; * Fix `tramp-test29-start-file-process' and +;; `tramp-test30-make-process' on MS Windows (`process-send-eof'?). ;; * Fix Bug#16928 in `tramp-test43-asynchronous-requests'. (provide 'tramp-tests) diff --git a/test/lisp/progmodes/sql-tests.el b/test/lisp/progmodes/sql-tests.el index 604c02172ea..a68f9319c2f 100644 --- a/test/lisp/progmodes/sql-tests.el +++ b/test/lisp/progmodes/sql-tests.el @@ -53,5 +53,106 @@ (error "some error")))) (should-not (sql-postgres-list-databases)))) +(defvar sql-test-login-params nil) +(defmacro with-sql-test-connect-harness (id login-params connection expected) + "Set-up and tear-down SQL connect related test. + +Identify tests by ID. Set :sql-login dialect attribute to +LOGIN-PARAMS. Provide the CONNECTION parameters and the EXPECTED +string of values passed to the comint function for validation." + (declare (indent 2)) + `(cl-letf + ((sql-test-login-params ' ,login-params) + ((symbol-function 'sql-comint-test) + (lambda (product options &optional buf-name) + (with-current-buffer (get-buffer-create buf-name) + (insert (pp-to-string (list product options sql-user sql-password sql-server sql-database)))))) + ((symbol-function 'sql-run-test) + (lambda (&optional buffer) + (interactive "P") + (sql-product-interactive 'sqltest buffer))) + (sql-user nil) + (sql-server nil) + (sql-database nil) + (sql-product-alist + '((ansi) + (sqltest + :name "SqlTest" + :sqli-login sql-test-login-params + :sqli-comint-func sql-comint-test))) + (sql-connection-alist + '((,(format "test-%s" id) + ,@connection))) + (sql-password-wallet + (list + (make-temp-file + "sql-test-netrc" nil nil + (mapconcat #'identity + '("machine aMachine user aUserName password \"netrc-A aPassword\"" + "machine aServer user aUserName password \"netrc-B aPassword\"" + "machine aMachine server aServer user aUserName password \"netrc-C aPassword\"" + "machine aMachine database aDatabase user aUserName password \"netrc-D aPassword\"" + "machine aDatabase user aUserName password \"netrc-E aPassword\"" + "machine aMachine server aServer database aDatabase user aUserName password \"netrc-F aPassword\"" + "machine \"aServer/aDatabase\" user aUserName password \"netrc-G aPassword\"" + ) "\n"))))) + + (let* ((connection ,(format "test-%s" id)) + (buffername (format "*SQL: ERT TEST <%s>*" connection))) + (when (get-buffer buffername) + (kill-buffer buffername)) + (sql-connect connection buffername) + (should (get-buffer buffername)) + (should (string-equal (with-current-buffer buffername (buffer-string)) ,expected)) + (when (get-buffer buffername) + (kill-buffer buffername)) + (delete-file (car sql-password-wallet))))) + +(ert-deftest sql-test-connect () + "Test of basic `sql-connect'." + (with-sql-test-connect-harness 1 (user password server database) + ((sql-product 'sqltest) + (sql-user "aUserName") + (sql-password "test-1 aPassword") + (sql-server "aServer") + (sql-database "aDatabase")) + "(sqltest nil \"aUserName\" \"test-1 aPassword\" \"aServer\" \"aDatabase\")\n")) + +(ert-deftest sql-test-connect-password-func () + "Test of password function." + (with-sql-test-connect-harness 2 (user password server database) + ((sql-product 'sqltest) + (sql-user "aUserName") + (sql-password (lambda () (concat [?t ?e ?s ?t ?- ?2 ?\s + ?a ?P ?a ?s ?s ?w ?o ?r ?d]))) + (sql-server "aServer") + (sql-database "aDatabase")) + "(sqltest nil \"aUserName\" \"test-2 aPassword\" \"aServer\" \"aDatabase\")\n")) + +(ert-deftest sql-test-connect-wallet-server-database () + "Test of password function." + (with-sql-test-connect-harness 3 (user password server database) + ((sql-product 'sqltest) + (sql-user "aUserName") + (sql-server "aServer") + (sql-database "aDatabase")) + "(sqltest nil \"aUserName\" \"netrc-G aPassword\" \"aServer\" \"aDatabase\")\n")) + +(ert-deftest sql-test-connect-wallet-database () + "Test of password function." + (with-sql-test-connect-harness 4 (user password database) + ((sql-product 'sqltest) + (sql-user "aUserName") + (sql-database "aDatabase")) + "(sqltest nil \"aUserName\" \"netrc-E aPassword\" nil \"aDatabase\")\n")) + +(ert-deftest sql-test-connect-wallet-server () + "Test of password function." + (with-sql-test-connect-harness 5 (user password server) + ((sql-product 'sqltest) + (sql-user "aUserName") + (sql-server "aServer")) + "(sqltest nil \"aUserName\" \"netrc-B aPassword\" \"aServer\" nil)\n")) + (provide 'sql-tests) ;;; sql-tests.el ends here |