commit 4231481af8fbaf895edc0754b4dcf4edc424ae9f (HEAD, refs/remotes/origin/master) Author: Thomas Fitzsimmons Date: Thu Nov 24 02:16:26 2022 -0500 EUDC: Improve LDAP and BBDB tests * test/lisp/net/eudc-tests.el (eudcb-ldap): Make slapd detection reliable. * test/lisp/net/eudc-resources/bbdb: Add another test contact. diff --git a/test/lisp/net/eudc-resources/bbdb b/test/lisp/net/eudc-resources/bbdb index b730bb51cc..782da56e9f 100644 --- a/test/lisp/net/eudc-resources/bbdb +++ b/test/lisp/net/eudc-resources/bbdb @@ -1,3 +1,4 @@ ;; -*- mode: Emacs-Lisp; coding: utf-8; -*- ;;; file-format: 9 ["Emacs" "ERT3" nil nil nil nil nil ("emacs-ert-test-3@bbdb.gnu.org") ((notes . " ")) "c8bd3a63-3a83-48a7-a95b-be118a923e00" "2022-11-19 16:36:04 +0000" "2022-11-19 16:36:04 +0000" nil] +["Emacs" "ERT4" nil nil nil nil nil ("emacs-ert-test-4@bbdb.gnu.org") ((notes . " ")) "5a93c3c5-9270-4e10-8b28-d28cfa2562cf" "2022-11-19 16:47:49 +0000" "2022-11-19 16:47:49 +0000" nil] diff --git a/test/lisp/net/eudc-tests.el b/test/lisp/net/eudc-tests.el index 212db65cb2..0da51b7c36 100644 --- a/test/lisp/net/eudc-tests.el +++ b/test/lisp/net/eudc-tests.el @@ -281,7 +281,12 @@ eudcb-ldap base "dc=gnu,dc=org" auth simple))) (eudc-server-hotlist '(("ldap://localhost:3899" . ldap))) (eudc-ignore-options-file t)) - (sleep-for 1) ; Wait for slapd to start. + (catch 'sldapd-up + (dotimes (_tries 20) + (when (eudc-query-with-words '("emacs-ert-test-1")) + (throw 'sldapd-up nil))) + (kill-process ldap-process) + (error "Failed to confirm slapd is running")) (should (equal (with-temp-buffer (insert "emacs-ert-test-1") (eudc-expand-try-all) commit 183c66be97c6b809f02cbcacb503a05fb982dabf Author: Yuan Fu Date: Wed Nov 23 19:46:38 2022 -0800 ; Relayout comments in treesit-font-lock-fontify-region ; * lisp/treesit.el (treesit-font-lock-fontify-region): Relayout comments. diff --git a/lisp/treesit.el b/lisp/treesit.el index 73a499bfa9..b8372d4f51 100644 --- a/lisp/treesit.el +++ b/lisp/treesit.el @@ -851,6 +851,32 @@ treesit--font-lock-fast-mode ;; applied by regexp-based font-lock. The clipped part will be ;; fontified fine when Emacs fontifies the region containing it. ;; +;; 2. If you insert an ending quote into a buffer, jit-lock only wants +;; to fontify that single quote, and (treesit-node-on start end) will +;; give you that quote node. We want to capture the string and apply +;; string face to it, but querying on the quote node will not give us +;; the string node. So we don't use treesit-node-on: using the root +;; node with a restricted range is very fast anyway (even in large +;; files of size ~10MB). Plus, querying the result of +;; `treesit-node-on' could still miss patterns even if we use some +;; heuristic to enlarge the node (how much to enlarge? to which +;; extent?), it's much safer to just use the root node. +;; +;; Sometimes the source file has some errors that cause tree-sitter to +;; parse it into a enormously tall tree (10k levels tall). In that +;; case querying the root node is very slow. So we try to get +;; top-level nodes and query them. This ensures that querying is fast +;; everywhere else, except for the problematic region. +;; +;; 3. It is possible to capture a node that's completely outside the +;; region between START and END: as long as the whole pattern +;; intersects the region, all the captured nodes in that pattern are +;; returned. If the node is outside of that region, (max node-start +;; start) and friends return bad values, so we filter them out. +;; However, we don't filter these nodes out if a function will process +;; the node, because could (and often do) fontify the relatives of the +;; captured node, not just the node itself. If we took out those +;; nodes author of those functions would be very confused. (defun treesit-font-lock-fontify-region (start end &optional loudly) "Fontify the region between START and END. If LOUDLY is non-nil, display some debugging information." @@ -863,35 +889,18 @@ treesit-font-lock-fontify-region (enable (nth 1 setting)) (override (nth 3 setting)) (language (treesit-query-language query))) - ;; If you insert an ending quote into a buffer, jit-lock only - ;; wants to fontify that single quote, and (treesit-node-on - ;; start end) will give you that quote node. We want to capture - ;; the string and apply string face to it, but querying on the - ;; quote node will not give us the string node. So we don't use - ;; treesit-node-on: using the root node with a restricted range - ;; is very fast anyway (even in large files of size ~10MB). - ;; Plus, querying the result of `treesit-node-on' could still - ;; miss patterns even if we use some heuristic to enlarge the - ;; node (how much to enlarge? to which extent?), it's much safer - ;; to just use the root node. - ;; - ;; Sometimes the source file has some errors that cause - ;; tree-sitter to parse it into a enormously tall tree (10k - ;; levels tall). In that case querying the root node is very - ;; slow. So we try to get top-level nodes and query them. This - ;; ensures that querying is fast everywhere else, except for the - ;; problematic region. (when-let ((nodes (list (treesit-buffer-root-node language))) ;; Only activate if ENABLE flag is t. (activate (eq t enable))) (ignore activate) ;; If we run into problematic files, use the "fast mode" to - ;; try to recover. + ;; try to recover. See comment #2 above for more explanation. (when treesit--font-lock-fast-mode (setq nodes (treesit--children-covering-range (car nodes) start end))) + ;; Query each node. (dolist (sub-node nodes) (let* ((delta-start (car treesit--font-lock-query-expand-range)) (delta-end (cdr treesit--font-lock-query-expand-range)) @@ -906,21 +915,18 @@ treesit-font-lock-fontify-region (when (> (time-to-seconds (time-subtract end-time start-time)) 0.01) (setq-local treesit--font-lock-fast-mode t)) + + ;; For each captured node, fontify that node. (with-silent-modifications (dolist (capture captures) (let* ((face (car capture)) (node (cdr capture)) (node-start (treesit-node-start node)) (node-end (treesit-node-end node))) - ;; It is possible to capture a node that's - ;; completely outside the region between START and - ;; END: as long as the whole pattern intersects the - ;; region, all the captured nodes in that pattern - ;; are returned. If the node is outside of that - ;; region, (max node-start start) and friends return - ;; bad values. - (if (and (facep face) (or (>= start node-end) - (>= node-start end))) + ;; If node is not in the region, take them out. See + ;; comment #3 above for more detail. + (if (and (facep face) + (or (>= start node-end) (>= node-start end))) (when (or loudly treesit--font-lock-verbose) (message "Captured node %s(%s-%s) but it is outside of fontifing region" node node-start node-end)) (cond commit d0cd4ae62e6996651dcfdc51222ae3fd9a68b4e3 Author: Yuan Fu Date: Wed Nov 23 19:34:10 2022 -0800 ; * lisp/progmodes/csharp-mode.el: Add missing require form. diff --git a/lisp/progmodes/csharp-mode.el b/lisp/progmodes/csharp-mode.el index 23d7b05d50..c507de94e0 100644 --- a/lisp/progmodes/csharp-mode.el +++ b/lisp/progmodes/csharp-mode.el @@ -27,6 +27,7 @@ (require 'compile) (require 'cc-mode) (require 'cc-langs) +(require 'treesit) (eval-when-compile (require 'cc-fonts)) commit 901f0eab20de5c2b5dd81a92309b08af06623623 Author: Yuan Fu Date: Wed Nov 23 17:35:15 2022 -0800 Add an error fontification heuristic to c-ts-mode * lisp/progmodes/c-ts-mode.el (c-ts-mode--font-lock-settings): Use new function. (c-ts-fontify-error): New function. diff --git a/lisp/progmodes/c-ts-mode.el b/lisp/progmodes/c-ts-mode.el index 3555eb23d1..fc35d9aedd 100644 --- a/lisp/progmodes/c-ts-mode.el +++ b/lisp/progmodes/c-ts-mode.el @@ -314,7 +314,7 @@ c-ts-mode--font-lock-settings :language mode :feature 'error - '((ERROR) @font-lock-warning-face) + '((ERROR) @c-ts-fontify-error) :feature 'escape-sequence :language mode @@ -421,6 +421,26 @@ c-ts-mode--fontify-defun (min end (treesit-node-end arg)) 'default override)))))) +(defun c-ts-fontify-error (node override start end &rest _) + "Fontify the error nodes. +For NODE, OVERRIDE, START, and END, see +`treesit-font-lock-rules'." + (let ((parent (treesit-node-parent node)) + (child (treesit-node-child node 0))) + (treesit-fontify-with-override + (max start (treesit-node-start node)) + (min end (treesit-node-end node)) + (cond + ;; This matches the case MACRO(struct a, b, c) + ;; where struct is seen as error. + ((and (equal (treesit-node-type child) "identifier") + (equal (treesit-node-type parent) "argument_list") + (member (treesit-node-text child) + '("struct" "long" "short" "enum" "union"))) + 'font-lock-keyword-face) + (t 'font-lock-warning-face)) + override))) + (defun c-ts-mode--imenu-1 (node) "Helper for `c-ts-mode--imenu'. Find string representation for NODE and set marker, then recurse commit 31fe6b066c39a9a38b0b8bb5bbae9e991ed87b2a Author: Yuan Fu Date: Wed Nov 23 17:24:03 2022 -0800 ; * src/treesit.c (treesit_predicate_match): Move use below check. diff --git a/src/treesit.c b/src/treesit.c index 4e07d4d084..7834eb1a68 100644 --- a/src/treesit.c +++ b/src/treesit.c @@ -2229,8 +2229,6 @@ treesit_predicate_match (Lisp_Object args, struct capture_range captures) Lisp_Object regexp = XCAR (args); Lisp_Object capture_name = XCAR (XCDR (args)); - Lisp_Object text = treesit_predicate_capture_name_to_text (capture_name, - captures); /* It's probably common to get the argument order backwards. Catch this mistake early and show helpful explanation, because Emacs @@ -2245,6 +2243,9 @@ treesit_predicate_match (Lisp_Object args, struct capture_range captures) build_pure_c_string ("The second argument to `match' should " "be a capture name, not a string")); + Lisp_Object text = treesit_predicate_capture_name_to_text (capture_name, + captures); + if (fast_string_match (regexp, text) >= 0) return true; else commit 00e7da76a7cf98239e9723624b1b5eb031636ce0 Author: Yuan Fu Date: Wed Nov 23 15:20:19 2022 -0800 Don't always filter out captured tree-sitter nodes outside of region * lisp/treesit.el (treesit-font-lock-fontify-region): If the capture name is a function, don't filter. diff --git a/lisp/treesit.el b/lisp/treesit.el index 3140358167..73a499bfa9 100644 --- a/lisp/treesit.el +++ b/lisp/treesit.el @@ -912,12 +912,17 @@ treesit-font-lock-fontify-region (node (cdr capture)) (node-start (treesit-node-start node)) (node-end (treesit-node-end node))) - ;; Turns out it is possible to capture a node that's + ;; It is possible to capture a node that's ;; completely outside the region between START and - ;; END. If the node is outside of that region, (max - ;; node-start start) and friends return bad values. - (when (and (< start node-end) - (< node-start end)) + ;; END: as long as the whole pattern intersects the + ;; region, all the captured nodes in that pattern + ;; are returned. If the node is outside of that + ;; region, (max node-start start) and friends return + ;; bad values. + (if (and (facep face) (or (>= start node-end) + (>= node-start end))) + (when (or loudly treesit--font-lock-verbose) + (message "Captured node %s(%s-%s) but it is outside of fontifing region" node node-start node-end)) (cond ((facep face) (treesit-fontify-with-override commit b37604c263e4813dc2a8b80e4e9131a3961c4f3e Author: Dmitry Gutov Date: Thu Nov 24 04:33:01 2022 +0200 project-switch-project: Use a different fix for bug#58784 * lisp/progmodes/project.el (project-current-inhibit-prompt): Rename to 'project-current-directory-override', and make it a string value. (project-current): Refer to it. (project-switch-project): Bind it. Drop the temp buffer (bug#58784). diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index c7b2c386cc..0e08dae154 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -175,8 +175,14 @@ project-find-functions `cl-defmethod' can dispatch on, like a cons cell, or a list, or a CL struct.") -(defvar project-current-inhibit-prompt nil - "Non-nil to skip prompting the user in `project-current'.") +(define-obsolete-variable-alias + 'project-current-inhibit-prompt + 'project-current-directory-override + "29.1") + +(defvar project-current-directory-override nil + "Value to use instead of `default-directory' when detecting the project. +When it is non-nil, `project-current' will always skip prompting too.") ;;;###autoload (defun project-current (&optional maybe-prompt directory) @@ -195,11 +201,12 @@ project-current See the doc string of `project-find-functions' for the general form of the project instance object." - (unless directory (setq directory default-directory)) + (unless directory (setq directory (or project-current-directory-override + default-directory))) (let ((pr (project--find-in-directory directory))) (cond (pr) - ((unless project-current-inhibit-prompt + ((unless project-current-directory-override maybe-prompt) (setq directory (project-prompt-project-dir) pr (project--find-in-directory directory)))) @@ -1698,10 +1705,8 @@ project-switch-project (let ((command (if (symbolp project-switch-commands) project-switch-commands (project--switch-project-command)))) - (with-temp-buffer - (let ((default-directory dir) - (project-current-inhibit-prompt t)) - (call-interactively command))))) + (let ((project-current-directory-override dir)) + (call-interactively command)))) (provide 'project) ;;; project.el ends here commit f8b410f4a16053d38aca1e4f8ac4bf426709f4ef Author: F. Jason Park Date: Sun Nov 20 19:01:32 2022 -0800 Add test scenarios for local ERC modules * test/lisp/erc/erc-scenarios-base-local-modules.el: New file. * test/lisp/erc/resources/base/local-modules/first.eld: New file. * test/lisp/erc/resources/base/local-modules/fourth.eld: New file * test/lisp/erc/resources/base/local-modules/second.eld: New file. * test/lisp/erc/resources/base/local-modules/third.eld: New file. (Bug#57955.) diff --git a/test/lisp/erc/erc-scenarios-base-local-modules.el b/test/lisp/erc/erc-scenarios-base-local-modules.el new file mode 100644 index 0000000000..417705de09 --- /dev/null +++ b/test/lisp/erc/erc-scenarios-base-local-modules.el @@ -0,0 +1,243 @@ +;;; erc-scenarios-local-modules.el --- Local modules tests for ERC -*- lexical-binding: t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. +;; +;; This file is part of GNU Emacs. +;; +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see +;; . + +;;; Code: + +;;; Commentary: + +;; These tests all use `sasl' because, as of ERC 5.5, it's the one +;; and only local module. + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +(require 'erc-sasl) + +;; This asserts that a local module's options and its inclusion in +;; (and absence from) `erc-update-modules' can be let-bound. + +(ert-deftest erc-scenarios-base-local-modules--reconnect-let () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "sasl") + (erc-server-flood-penalty 0.1) + (dumb-server (erc-d-run "localhost" t 'plain 'plain)) + (port (process-contact dumb-server :service)) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect with options let-bound") + (with-current-buffer + ;; This won't work unless the library is already loaded + (let ((erc-modules (cons 'sasl erc-modules)) + (erc-sasl-mechanism 'plain) + (erc-sasl-password "password123")) + (erc :server "127.0.0.1" + :port port + :nick "tester" + :user "tester" + :full-name "tester")) + (should (string= (buffer-name) (format "127.0.0.1:%d" port))))) + + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "ExampleOrg")) + + (ert-info ("First connection succeeds") + (funcall expect 10 "This server is in debug mode") + (erc-cmd-QUIT "") + (funcall expect 10 "finished")) + + (should-not (memq 'sasl erc-modules)) + (erc-d-t-wait-for 10 (not (erc-server-process-alive))) + (erc-cmd-RECONNECT) + + (ert-info ("Second connection succeeds") + (funcall expect 10 "This server is in debug mode") + (erc-cmd-QUIT "") + (funcall expect 10 "finished"))))) + +;; After quitting a session for which `sasl' is enabled, you +;; disconnect and toggle `erc-sasl-mode' off. You then reconnect +;; using an alternate nickname. You again disconnect and reconnect, +;; this time immediately, and the mode stays disabled. Finally, you +;; once again disconnect, toggle the mode back on, and reconnect. You +;; are authenticated successfully, just like in the initial session. +;; +;; This is meant to show that a user's local mode settings persist +;; between sessions. It also happens to show (in round four, below) +;; that a server renicking a user on 001 after a 903 is handled just +;; like a user-initiated renick, although this is not the main thrust. + +(ert-deftest erc-scenarios-base-local-modules--mode-persistence () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/local-modules") + (erc-server-flood-penalty 0.1) + (dumb-server (erc-d-run "localhost" t 'first 'second 'third 'fourth)) + (port (process-contact dumb-server :service)) + (erc-modules (cons 'sasl erc-modules)) + (expect (erc-d-t-make-expecter)) + (server-buffer-name (format "127.0.0.1:%d" port))) + + (ert-info ("Round one, initial authentication succeeds as expected") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :user "tester" + :password "changeme" + :full-name "tester") + (should (string= (buffer-name) server-buffer-name)) + (funcall expect 10 "You are now logged in as tester")) + + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "foonet")) + (funcall expect 10 "This server is in debug mode") + (erc-cmd-JOIN "#chan") + + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) + (funcall expect 20 "She is Lavinia, therefore must")) + + (erc-cmd-QUIT "") + (funcall expect 10 "finished"))) + + (ert-info ("Round two, nick rejected, alternate granted") + (with-current-buffer "foonet" + + (ert-info ("Toggle mode off, reconnect") + (erc-sasl-mode -1) + (erc-cmd-RECONNECT)) + + (funcall expect 10 "User modes for tester`") + (should-not (cdr (erc-scenarios-common-buflist "foonet"))) + (should (equal (buffer-name) "foonet")) + (should-not (cdr (erc-scenarios-common-buflist "#chan"))) + + (with-current-buffer "#chan" + (funcall expect 10 "Some enigma, some riddle")) + + (erc-cmd-QUIT "") + (funcall expect 10 "finished"))) + + (ert-info ("Round three, send alternate nick initially") + (with-current-buffer "foonet" + + (ert-info ("Keep mode off, reconnect") + (should-not erc-sasl-mode) + (should (local-variable-p 'erc-sasl-mode)) + (erc-cmd-RECONNECT)) + + (funcall expect 10 "User modes for tester`") + (should-not (cdr (erc-scenarios-common-buflist "foonet"))) + (should (equal (buffer-name) "foonet")) + (should-not (cdr (erc-scenarios-common-buflist "#chan"))) + + (with-current-buffer "#chan" + (funcall expect 10 "Let our reciprocal vows be remembered.")) + + (erc-cmd-QUIT "") + (funcall expect 10 "finished"))) + + (ert-info ("Round four, authenticated successfully again") + (with-current-buffer "foonet" + + (ert-info ("Toggle mode on, reconnect") + (should-not erc-sasl-mode) + (should (local-variable-p 'erc-sasl-mode)) + (erc-sasl-mode +1) + (erc-cmd-RECONNECT)) + + (funcall expect 10 "User modes for tester") + (should-not (cdr (erc-scenarios-common-buflist "foonet"))) + (should (equal (buffer-name) "foonet")) + (should-not (cdr (erc-scenarios-common-buflist "#chan"))) + + (with-current-buffer "#chan" + (funcall expect 10 "Well met; good morrow, Titus and Hortensius.")) + + (erc-cmd-QUIT ""))))) + +;; For local modules, the twin toggle commands `erc-FOO-enable' and +;; `erc-FOO-disable' affect all buffers of a connection, whereas +;; `erc-FOO-mode' continues to operate only on the current buffer. + +(ert-deftest erc-scenarios-base-local-modules--toggle-helpers () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/local-modules") + (erc-server-flood-penalty 0.1) + (dumb-server (erc-d-run "localhost" t 'first 'second 'fourth)) + (port (process-contact dumb-server :service)) + (erc-modules (cons 'sasl erc-modules)) + (expect (erc-d-t-make-expecter)) + (server-buffer-name (format "127.0.0.1:%d" port))) + + (ert-info ("Initial authentication succeeds as expected") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :user "tester" + :password "changeme" + :full-name "tester") + (should (string= (buffer-name) server-buffer-name)) + (funcall expect 10 "You are now logged in as tester")) + + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "foonet")) + (funcall expect 10 "This server is in debug mode") + (erc-cmd-JOIN "#chan") + + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) + (funcall expect 20 "She is Lavinia, therefore must")) + + (erc-cmd-QUIT "") + (funcall expect 10 "finished"))) + + (ert-info ("Disabling works from a target buffer.") + (with-current-buffer "#chan" + (should erc-sasl-mode) + (call-interactively #'erc-sasl-disable) + (should-not erc-sasl-mode) + (should (local-variable-p 'erc-sasl-mode)) + (should-not (buffer-local-value 'erc-sasl-mode (get-buffer "foonet"))) + (erc-cmd-RECONNECT) + (with-current-buffer "#chan" + (funcall expect 10 "Some enigma, some riddle") + (should-not erc-sasl-mode) ; regression + (should (local-variable-p 'erc-sasl-mode)))) + + (with-current-buffer "foonet" + (should (local-variable-p 'erc-sasl-mode)) + (funcall expect 10 "User modes for tester`") + (erc-cmd-QUIT "") + (funcall expect 10 "finished"))) + + (ert-info ("Enabling works from a target buffer") + (with-current-buffer "#chan" + (call-interactively #'erc-sasl-enable) + (should (local-variable-p 'erc-sasl-mode)) + (should erc-sasl-mode) + (erc-cmd-RECONNECT) + (funcall expect 10 "Well met; good morrow, Titus and Hortensius.") + (erc-cmd-QUIT "")) + + (with-current-buffer "foonet" + (should (local-variable-p 'erc-sasl-mode)) + (should erc-sasl-mode) + (funcall expect 10 "User modes for tester"))))) + +;;; erc-scenarios-local-modules.el ends here diff --git a/test/lisp/erc/resources/base/local-modules/first.eld b/test/lisp/erc/resources/base/local-modules/first.eld new file mode 100644 index 0000000000..f9181a80fb --- /dev/null +++ b/test/lisp/erc/resources/base/local-modules/first.eld @@ -0,0 +1,53 @@ +;; -*- mode: lisp-data; -*- +((cap 10 "CAP REQ :sasl")) +((nick 1 "NICK tester")) +((user 1 "USER tester 0 * :tester")) + +((authenticate 5 "AUTHENTICATE PLAIN") + (0.0 ":irc.foonet.org CAP * ACK sasl") + (0.0 "AUTHENTICATE +")) + +((authenticate 5 "AUTHENTICATE AHRlc3RlcgBjaGFuZ2VtZQ==") + (0.0 ":irc.foonet.org 900 * * tester :You are now logged in as tester") + (0.01 ":irc.foonet.org 903 * :Authentication successful")) + +((cap 3.2 "CAP END") + (0.0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") + (0.0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.8.0") + (0.2 ":irc.foonet.org 003 tester :This server was created Sun, 20 Nov 2022 23:10:36 UTC") + (0.0 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.8.0 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0.0 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX KICKLEN=390 :are supported by this server") + (0.0 ":irc.foonet.org 005 tester MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8MAPPING=rfc8265 UTF8ONLY WHOX :are supported by this server") + (0.0 ":irc.foonet.org 005 tester draft/CHATHISTORY=100 :are supported by this server") + (0.0 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)") + (0.0 ":irc.foonet.org 252 tester 0 :IRC Operators online") + (0.0 ":irc.foonet.org 253 tester 0 :unregistered connections") + (0.0 ":irc.foonet.org 254 tester 1 :channels formed") + (0.0 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers") + (0.0 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3") + (0.0 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3") + (0.0 ":irc.foonet.org 422 tester :MOTD File is missing") + (0.0 ":irc.foonet.org 221 tester +i") + (0.0 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.")) + +((mode 10 "MODE tester +i") + (0.02 ":irc.foonet.org 221 tester +i")) + +((join 10 "JOIN #chan") + (0.00 ":tester!~u@u9iqi96sfwk9s.irc JOIN #chan") + (0.06 ":irc.foonet.org 353 tester = #chan :@bob alice tester") + (0.01 ":irc.foonet.org 366 tester #chan :End of NAMES list") + (0.02 ":bob!~u@2fzfcku68ehqa.irc PRIVMSG #chan :tester, welcome!") + (0.01 ":alice!~u@2fzfcku68ehqa.irc PRIVMSG #chan :tester, welcome!") + (0.04 ":alice!~u@2fzfcku68ehqa.irc PRIVMSG #chan :bob: Either your unparagoned mistress is dead, or she's outprized by a trifle.")) + +((mode 12 "MODE #chan") + (0.00 ":irc.foonet.org 324 tester #chan +nt") + (0.02 ":irc.foonet.org 329 tester #chan 1668985854") + (0.98 ":bob!~u@2fzfcku68ehqa.irc PRIVMSG #chan :alice: Come, you are a tedious fool: to the purpose. What was done to Elbow's wife, that he hath cause to complain of ? Come me to what was done to her.") + (0.01 ":alice!~u@2fzfcku68ehqa.irc PRIVMSG #chan :bob: She is Lavinia, therefore must be lov'd.")) + +((quit 10 "QUIT :\2ERC\2") + (0.02 ":tester!~u@u9iqi96sfwk9s.irc QUIT :Quit")) + +((drop 0 DROP)) diff --git a/test/lisp/erc/resources/base/local-modules/fourth.eld b/test/lisp/erc/resources/base/local-modules/fourth.eld new file mode 100644 index 0000000000..fd6d62b6cc --- /dev/null +++ b/test/lisp/erc/resources/base/local-modules/fourth.eld @@ -0,0 +1,53 @@ +;; -*- mode: lisp-data; -*- +((cap 10 "CAP REQ :sasl")) +((nick 10 "NICK tester`")) +((user 10 "USER tester 0 * :tester")) + +((authenticate 10 "AUTHENTICATE PLAIN") + (0.0 ":irc.foonet.org CAP * ACK sasl") + (0.0 "AUTHENTICATE +")) + +((authenticate 10 "AUTHENTICATE AHRlc3RlcgBjaGFuZ2VtZQ==") + (0.00 ":irc.foonet.org 900 * * tester :You are now logged in as tester") + (0.01 ":irc.foonet.org 903 * :Authentication successful")) + +((cap 10 "CAP END") + (0.00 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") + (0.01 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version ergo-v2.8.0") + (0.01 ":irc.foonet.org 003 tester :This server was created Sun, 20 Nov 2022 23:10:36 UTC") + (0.01 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.8.0 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0.13 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX KICKLEN=390 :are supported by this server") + (0.01 ":irc.foonet.org 005 tester MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8MAPPING=rfc8265 UTF8ONLY WHOX :are supported by this server") + (0.03 ":irc.foonet.org 005 tester draft/CHATHISTORY=100 :are supported by this server") + (0.00 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)") + (0.00 ":irc.foonet.org 252 tester 0 :IRC Operators online") + (0.00 ":irc.foonet.org 253 tester 0 :unregistered connections") + (0.00 ":irc.foonet.org 254 tester 1 :channels formed") + (0.00 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers") + (0.00 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3") + (0.00 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3") + (0.03 ":irc.foonet.org 422 tester :MOTD File is missing") + (0.02 ":irc.foonet.org 221 tester +i") + (0.00 ":irc.foonet.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.")) + +((mode 10 "MODE tester +i") + (0.0 ":irc.foonet.org 221 tester +i")) + +((join 10 "JOIN #chan") + (0.00 ":tester!~u@u9iqi96sfwk9s.irc JOIN #chan") + (0.09 ":irc.foonet.org 353 tester = #chan :alice tester @bob") + (0.01 ":irc.foonet.org 366 tester #chan :End of NAMES list") + (0.00 ":alice!~u@2fzfcku68ehqa.irc PRIVMSG #chan :tester, welcome!") + (0.00 ":bob!~u@2fzfcku68ehqa.irc PRIVMSG #chan :tester, welcome!") + (0.03 ":alice!~u@2fzfcku68ehqa.irc PRIVMSG #chan :bob: And both shall cease, without your remedy.") + (0.02 ":bob!~u@2fzfcku68ehqa.irc PRIVMSG #chan :alice: Nay, tarry; I'll go along with thee: I can tell thee pretty tales of the duke.")) + +((mode 10 "MODE #chan") + (0.00 ":irc.foonet.org 324 tester #chan +nt") + (0.01 ":irc.foonet.org 329 tester #chan 1668985854") + (0.03 ":alice!~u@2fzfcku68ehqa.irc PRIVMSG #chan :bob: Do: I'll take the sacrament on't, how and which way you will.") + (0.00 ":bob!~u@2fzfcku68ehqa.irc PRIVMSG #chan :alice: Worthy Macbeth, we stay upon your leisure.") + (0.00 ":alice!~u@2fzfcku68ehqa.irc PRIVMSG #chan :bob: Well met; good morrow, Titus and Hortensius.")) + +((quit 10 "QUIT :\2ERC\2") + (0.03 ":tester!~u@u9iqi96sfwk9s.irc QUIT :Quit")) diff --git a/test/lisp/erc/resources/base/local-modules/second.eld b/test/lisp/erc/resources/base/local-modules/second.eld new file mode 100644 index 0000000000..a96103b2aa --- /dev/null +++ b/test/lisp/erc/resources/base/local-modules/second.eld @@ -0,0 +1,47 @@ +;; -*- mode: lisp-data; -*- +((pass 10 "PASS :changeme")) +((nick 1 "NICK tester")) +((user 1 "USER tester 0 * :tester") + (0.0 ":irc.foonet.org 433 * tester :Nickname is reserved by a different account")) + +((nick 10 "NICK tester`") + (0.01 ":irc.foonet.org FAIL NICK NICKNAME_RESERVED tester :Nickname is reserved by a different account") + (0.06 ":irc.foonet.org 001 tester` :Welcome to the foonet IRC Network tester`") + (0.01 ":irc.foonet.org 002 tester` :Your host is irc.foonet.org, running version ergo-v2.8.0") + (0.01 ":irc.foonet.org 003 tester` :This server was created Sun, 20 Nov 2022 23:10:36 UTC") + (0.01 ":irc.foonet.org 004 tester` irc.foonet.org ergo-v2.8.0 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0.01 ":irc.foonet.org 005 tester` AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX KICKLEN=390 :are supported by this server") + (0.01 ":irc.foonet.org 005 tester` MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8MAPPING=rfc8265 UTF8ONLY WHOX :are supported by this server") + (0.01 ":irc.foonet.org 005 tester` draft/CHATHISTORY=100 :are supported by this server") + (0.00 ":irc.foonet.org 251 tester` :There are 0 users and 3 invisible on 1 server(s)") + (0.00 ":irc.foonet.org 252 tester` 0 :IRC Operators online") + (0.02 ":irc.foonet.org 253 tester` 0 :unregistered connections") + (0.00 ":irc.foonet.org 254 tester` 1 :channels formed") + (0.00 ":irc.foonet.org 255 tester` :I have 3 clients and 0 servers") + (0.00 ":irc.foonet.org 265 tester` 3 3 :Current local users 3, max 3") + (0.00 ":irc.foonet.org 266 tester` 3 3 :Current global users 3, max 3") + (0.00 ":irc.foonet.org 422 tester` :MOTD File is missing") + (0.02 ":irc.foonet.org 221 tester` +i") + (0.00 ":irc.foonet.org NOTICE tester` :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.")) + +((mode 12 "MODE tester` +i") + (0.0 ":irc.foonet.org 221 tester` +i")) + +((join 10 "JOIN #chan") + (0.00 ":tester`!~u@u9iqi96sfwk9s.irc JOIN #chan") + (0.08 ":irc.foonet.org 353 tester` = #chan :@bob alice tester`") + (0.01 ":irc.foonet.org 366 tester` #chan :End of NAMES list") + (0.00 ":alice!~u@2fzfcku68ehqa.irc PRIVMSG #chan :tester`, welcome!") + (0.01 ":bob!~u@2fzfcku68ehqa.irc PRIVMSG #chan :tester`, welcome!") + (0.05 ":bob!~u@2fzfcku68ehqa.irc PRIVMSG #chan :alice: And Jove, for your love, would infringe an oath.")) + +((mode 10 "MODE #chan") + (0.00 ":irc.foonet.org 324 tester` #chan +nt") + (0.02 ":irc.foonet.org 329 tester` #chan 1668985854") + (0.07 ":alice!~u@2fzfcku68ehqa.irc PRIVMSG #chan :bob: To you that know them not. This to my mother.") + (0.00 ":bob!~u@2fzfcku68ehqa.irc PRIVMSG #chan :alice: Some enigma, some riddle: come, thy l'envoy; begin.")) + +((quit 1 "QUIT :\2ERC\2") + (0.03 ":tester`!~u@u9iqi96sfwk9s.irc QUIT")) + +((drop 0 DROP)) diff --git a/test/lisp/erc/resources/base/local-modules/third.eld b/test/lisp/erc/resources/base/local-modules/third.eld new file mode 100644 index 0000000000..060083656a --- /dev/null +++ b/test/lisp/erc/resources/base/local-modules/third.eld @@ -0,0 +1,43 @@ +;; -*- mode: lisp-data; -*- +((pass 10 "PASS :changeme")) +((nick 1 "NICK tester`")) +((user 1 "USER tester 0 * :tester") + (0.06 ":irc.foonet.org 001 tester` :Welcome to the foonet IRC Network tester`") + (0.01 ":irc.foonet.org 002 tester` :Your host is irc.foonet.org, running version ergo-v2.8.0") + (0.01 ":irc.foonet.org 003 tester` :This server was created Sun, 20 Nov 2022 23:10:36 UTC") + (0.01 ":irc.foonet.org 004 tester` irc.foonet.org ergo-v2.8.0 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0.01 ":irc.foonet.org 005 tester` AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX KICKLEN=390 :are supported by this server") + (0.01 ":irc.foonet.org 005 tester` MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=foonet NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8MAPPING=rfc8265 UTF8ONLY WHOX :are supported by this server") + (0.01 ":irc.foonet.org 005 tester` draft/CHATHISTORY=100 :are supported by this server") + (0.00 ":irc.foonet.org 251 tester` :There are 0 users and 3 invisible on 1 server(s)") + (0.00 ":irc.foonet.org 252 tester` 0 :IRC Operators online") + (0.02 ":irc.foonet.org 253 tester` 0 :unregistered connections") + (0.00 ":irc.foonet.org 254 tester` 1 :channels formed") + (0.00 ":irc.foonet.org 255 tester` :I have 3 clients and 0 servers") + (0.00 ":irc.foonet.org 265 tester` 3 3 :Current local users 3, max 3") + (0.00 ":irc.foonet.org 266 tester` 3 3 :Current global users 3, max 3") + (0.00 ":irc.foonet.org 422 tester` :MOTD File is missing") + (0.02 ":irc.foonet.org 221 tester` +i") + (0.00 ":irc.foonet.org NOTICE tester` :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.")) + +((mode 12 "MODE tester` +i") + (0.0 ":irc.foonet.org 221 tester` +i")) + +((join 10 "JOIN #chan") + (0.00 ":tester`!~u@u9iqi96sfwk9s.irc JOIN #chan") + (0.08 ":irc.foonet.org 353 tester` = #chan :@bob alice tester`") + (0.01 ":irc.foonet.org 366 tester` #chan :End of NAMES list") + (0.00 ":alice!~u@2fzfcku68ehqa.irc PRIVMSG #chan :tester`, welcome!") + (0.01 ":bob!~u@2fzfcku68ehqa.irc PRIVMSG #chan :tester`, welcome!") + (0.05 ":bob!~u@2fzfcku68ehqa.irc PRIVMSG #chan :alice: With pomp, with triumph, and with revelling.")) + +((mode 10 "MODE #chan") + (0.00 ":irc.foonet.org 324 tester` #chan +nt") + (0.02 ":irc.foonet.org 329 tester` #chan 1668985854") + (0.00 ":alice!~u@2fzfcku68ehqa.irc PRIVMSG #chan :bob: No remedy, my lord, when walls are so wilful to hear without warning.") + (0.01 ":bob!~u@2fzfcku68ehqa.irc PRIVMSG #chan :alice: Let our reciprocal vows be remembered. You have many opportunities to cut him off; if your will want not, time and place will be fruitfully offered. There is nothing done if he return the conqueror; then am I the prisoner, and his bed my gaol; from the loathed warmth whereof deliver me, and supply the place for your labour.")) + +((quit 1 "QUIT :\2ERC\2") + (0.03 ":tester`!~u@u9iqi96sfwk9s.irc QUIT :Quit")) + +((drop 0 DROP)) commit 5258f3616812da63526da7b1aadfe26fc384ef2a Author: F. Jason Park Date: Sun Nov 13 01:52:48 2022 -0800 Accept functions in place of passwords in ERC * lisp/erc/erc-backend.el (erc-session-password): Add comment explaining type is now string, nil, or function. * lisp/erc/erc-compat.el (erc-compat--29-auth-source-pass-search): Use obfuscation from auth-source function when available. * lisp/erc/erc-sasl.el (erc-sasl--read-password, erc-server-AUTHENTICATE): Use `erc--unfun'. * lisp/erc/erc-services.el (erc-nickserv-get-password, erc-nickserv-send-identify): Use `erc--unfun'. * lisp/erc/erc.el (erc--unfun): New function for unwrapping a password couched in a getter. (erc--debug-irc-protocol-mask-secrets): Add variable to indicate whether to mask passwords in debug logs. (erc--mask-secrets): New function to swap masked secret with question marks in debug logs. (erc-log-irc-protocol): Conditionally mask secrets when `erc--debug-irc-protocol-mask-secrets' is non-nil. (erc--auth-source-search): Don't unwrap secret from function before returning. (erc-server-join-channel, erc-login): Use `erc--unfun'. * test/lisp/erc/erc-services-tests.el (erc-services-tests--wrap-search): Add helper for `erc--unfun'. (erc-services-tests--auth-source-standard, erc-services-tests--auth-source-announced, erc-services-tests--auth-source-overrides, erc-nickserv-get-password): Use `erc--unfun'. * test/lisp/erc/erc-tests.el (erc--debug-irc-protocol-mask-secrets): Add test for masking secrets with `erc--unfun' and friends. diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 6e91353808..43c5faad63 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -205,7 +205,8 @@ erc-whowas-on-nosuchnick ;;;; Variables and options (defvar-local erc-session-password nil - "The password used for the current session.") + "The password used for the current session. +This should be a string or a function returning a string.") (defvar erc-server-responses (make-hash-table :test #'equal) "Hash table mapping server responses to their handler hooks.") diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el index 4893f6ce59..66a9a615e3 100644 --- a/lisp/erc/erc-compat.el +++ b/lisp/erc/erc-compat.el @@ -252,8 +252,18 @@ erc-compat--29-auth-source-pass-search ;; From `auth-source-pass-search' (cl-assert (and host (not (eq host t))) t "Invalid password-store search: %s %s") - (erc-compat--29-auth-source-pass--build-result-many - host user port require max)) + (let ((rv (erc-compat--29-auth-source-pass--build-result-many + host user port require max))) + (if (and (fboundp 'auth-source--obfuscate) + (fboundp 'auth-source--deobfuscate)) + (let (out) + (dolist (e rv out) + (when-let* ((s (plist-get e :secret)) + (v (auth-source--obfuscate s))) + (setf (plist-get e :secret) + (byte-compile (lambda () (auth-source--deobfuscate v))))) + (push e out))) + rv))) (defun erc-compat--29-auth-source-pass-backend-parse (entry) (when (eq entry 'password-store) diff --git a/lisp/erc/erc-sasl.el b/lisp/erc/erc-sasl.el index ab171ea4d3..9084d873ce 100644 --- a/lisp/erc/erc-sasl.el +++ b/lisp/erc/erc-sasl.el @@ -143,7 +143,7 @@ erc-sasl--read-password (apply erc-sasl-auth-source-function :user (erc-sasl--get-user) (and host (list :host (symbol-name host)))))))) - (copy-sequence found) + (copy-sequence (erc--unfun found)) (read-passwd prompt))) (defun erc-sasl--plain-response (client steps) @@ -353,7 +353,7 @@ sasl (when (string= data "") (setq data nil)) (when data - (setq data (base64-encode-string data t))) + (setq data (erc--unfun (base64-encode-string data t)))) (erc-server-send (concat "AUTHENTICATE " (or data "+")))))) (defun erc-sasl--destroy (proc) diff --git a/lisp/erc/erc-services.el b/lisp/erc/erc-services.el index fe9cb5b5f1..48953288d1 100644 --- a/lisp/erc/erc-services.el +++ b/lisp/erc/erc-services.el @@ -455,7 +455,7 @@ erc-nickserv-get-password (read-passwd (format "NickServ password for %s on %s (RET to cancel): " nick nid))))) - ((not (string-empty-p ret)))) + ((not (string-empty-p (erc--unfun ret))))) ret)) (defvar erc-auto-discard-away) @@ -477,7 +477,8 @@ erc-nickserv-send-identify (msgtype (or (erc-nickserv-alist-ident-command nil nickserv-info) "PRIVMSG"))) (erc-message msgtype - (concat nickserv " " identify-word " " nick password)))) + (concat nickserv " " identify-word " " nick + (erc--unfun password))))) (defun erc-nickserv-call-identify-function (nickname) "Call `erc-nickserv-identify' with NICKNAME." diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 63093d509b..268d83dc44 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -2335,6 +2335,23 @@ erc-debug-irc-protocol WARNING: Do not set this variable directly! Instead, use the function `erc-toggle-debug-irc-protocol' to toggle its value.") +(defvar erc--debug-irc-protocol-mask-secrets t + "Whether to hide secrets in a debug log. +They are still visible on screen but are replaced by question +marks when yanked.") + +(defun erc--mask-secrets (string) + (when-let* ((eot (length string)) + (beg (text-property-any 0 eot 'erc-secret t string)) + (end (text-property-not-all beg eot 'erc-secret t string)) + (sec (substring string beg end))) + (setq string (concat (substring string 0 beg) + (make-string 10 ??) + (substring string end eot))) + (put-text-property beg (+ 10 beg) 'face 'erc-inverse-face string) + (put-text-property beg (+ 10 beg) 'display sec string)) + string) + (defun erc-log-irc-protocol (string &optional outbound) "Append STRING to the buffer *erc-protocol*. @@ -2360,6 +2377,8 @@ erc-log-irc-protocol (format "%s:%s" erc-session-server erc-session-port)))) (ts (when erc-debug-irc-protocol-time-format (format-time-string erc-debug-irc-protocol-time-format)))) + (when erc--debug-irc-protocol-mask-secrets + (setq string (erc--mask-secrets string))) (with-current-buffer (get-buffer-create "*erc-protocol*") (save-excursion (goto-char (point-max)) @@ -3285,9 +3304,8 @@ erc--auth-source-search (setq plist (plist-put plist :max 5000))) ; `auth-source-netrc-parse' (unless (plist-get defaults :require) (setq plist (plist-put plist :require '(:secret)))) - (when-let* ((sorted (sort (apply #'auth-source-search plist) test)) - (secret (plist-get (car sorted) :secret))) - (if (functionp secret) (funcall secret) secret)))) + (when-let* ((sorted (sort (apply #'auth-source-search plist) test))) + (plist-get (car sorted) :secret)))) (defun erc-auth-source-search (&rest plist) "Call `auth-source-search', possibly with keyword params in PLIST." @@ -3308,7 +3326,8 @@ erc-server-join-channel (setq secret (apply erc-auth-source-join-function `(,@(and server (list :host server)) :user ,channel)))) (erc-log (format "cmd: JOIN: %s" channel)) - (erc-server-send (concat "JOIN " channel (and secret (concat " " secret))))) + (erc-server-send (concat "JOIN " channel + (and secret (concat " " (erc--unfun secret)))))) (defun erc--valid-local-channel-p (channel) "Non-nil when channel is server-local on a network that allows them." @@ -6344,6 +6363,15 @@ erc-load-irc-script-lines ;; authentication +(defun erc--unfun (maybe-fn) + "Return MAYBE-FN or whatever it returns." + (let ((s (if (functionp maybe-fn) (funcall maybe-fn) maybe-fn))) + (when (and erc-debug-irc-protocol + erc--debug-irc-protocol-mask-secrets + (stringp s)) + (put-text-property 0 (length s) 'erc-secret t s)) + s)) + (defun erc-login () "Perform user authentication at the IRC server." (erc-log (format "login: nick: %s, user: %s %s %s :%s" @@ -6353,7 +6381,7 @@ erc-login erc-session-server erc-session-user-full-name)) (if erc-session-password - (erc-server-send (concat "PASS :" erc-session-password)) + (erc-server-send (concat "PASS :" (erc--unfun erc-session-password))) (message "Logging in without password")) (erc-server-send (format "NICK %s" (erc-current-nick))) (erc-server-send diff --git a/test/lisp/erc/erc-services-tests.el b/test/lisp/erc/erc-services-tests.el index 7ff2e36e77..2547c5e01a 100644 --- a/test/lisp/erc/erc-services-tests.el +++ b/test/lisp/erc/erc-services-tests.el @@ -62,9 +62,13 @@ erc--auth-source-determine-params-merge :x ("x") :require (:secret)))))) +(defun erc-services-tests--wrap-search (s) + (lambda (&rest r) (erc--unfun (apply s r)))) + ;; Some of the following may be related to bug#23438. (defun erc-services-tests--auth-source-standard (search) + (setq search (erc-services-tests--wrap-search search)) (ert-info ("Session wins") (let ((erc-session-server "irc.gnu.org") @@ -93,6 +97,7 @@ erc-services-tests--auth-source-standard (should (string= (funcall search :user "#chan") "baz"))))) (defun erc-services-tests--auth-source-announced (search) + (setq search (erc-services-tests--wrap-search search)) (let* ((erc--isupport-params (make-hash-table)) (erc-server-parameters '(("CHANTYPES" . "&#"))) (erc--target (erc--target-from-string "&chan"))) @@ -124,6 +129,7 @@ erc-services-tests--auth-source-announced (should (string= (funcall search :user "#chan") "foo"))))))) (defun erc-services-tests--auth-source-overrides (search) + (setq search (erc-services-tests--wrap-search search)) (let* ((erc-session-server "irc.gnu.org") (erc-server-announced-name "my.gnu.org") (erc-network 'GNU.chat) @@ -537,18 +543,20 @@ erc-nickserv-get-password (erc-network 'FSF.chat) (erc-server-current-nick "tester") (erc-networks--id (erc-networks--id-create nil)) - (erc-session-port 6697)) + (erc-session-port 6697) + (search (erc-services-tests--wrap-search + #'erc-nickserv-get-password))) (ert-info ("Lookup custom option") - (should (string= (erc-nickserv-get-password "alice") "foo"))) + (should (string= (funcall search "alice") "foo"))) (ert-info ("Auth source") (ert-info ("Network") - (should (string= (erc-nickserv-get-password "bob") "sesame"))) + (should (string= (funcall search "bob") "sesame"))) (ert-info ("Network ID") (let ((erc-networks--id (erc-networks--id-create 'GNU/chat))) - (should (string= (erc-nickserv-get-password "bob") "spam"))))) + (should (string= (funcall search "bob") "spam"))))) (ert-info ("Read input") (should (string= diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index b185d850a6..4d0d69cd7b 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -530,6 +530,28 @@ erc-ring-previous-command (when noninteractive (kill-buffer "*#fake*"))) +(ert-deftest erc--debug-irc-protocol-mask-secrets () + (should-not erc-debug-irc-protocol) + (should erc--debug-irc-protocol-mask-secrets) + (with-temp-buffer + (setq erc-server-process (start-process "fake" (current-buffer) "true") + erc-server-current-nick "tester" + erc-session-server "myproxy.localhost" + erc-session-port 6667) + (let ((inhibit-message noninteractive)) + (erc-toggle-debug-irc-protocol) + (erc-log-irc-protocol + (concat "PASS :" (erc--unfun (lambda () "changeme")) "\r\n") + 'outgoing) + (set-process-query-on-exit-flag erc-server-process nil)) + (with-current-buffer "*erc-protocol*" + (goto-char (point-min)) + (search-forward "\r\n\r\n") + (search-forward "myproxy.localhost:6667 >> PASS :????????" (pos-eol))) + (when noninteractive + (kill-buffer "*erc-protocol*") + (should-not erc-debug-irc-protocol)))) + (ert-deftest erc-log-irc-protocol () (should-not erc-debug-irc-protocol) (with-temp-buffer commit ed8862c40432302b68433a9b8c00cd5604962ec4 Author: F. Jason Park Date: Mon Jul 12 03:44:28 2021 -0700 Add non-IRCv3 SASL module to ERC * doc/misc/erc.texi: Add SASL section in Advanced Usage chapter to document the new SASL module. * etc/ERC-NEWS: Mention addition of erc-sasl module for SASL support. * lisp/erc/erc-compat.el (erc-compat--29-sasl-scram-construct-gs2-header, erc-compat--29-sasl-scram-client-first-message, erc-compat--29-sasl-scram--client-final-message): Fix encoding bug and add minimal authorization support with copies of SASL functions introduced in Emacs 29. * lisp/erc/erc.el (erc-modules): Add `sasl'. * lisp/erc/erc-sasl.el: New file (bug#29108). * test/lisp/erc/erc-sasl-tests.el: New file. * test/lisp/erc/erc-scenarios-sasl.el: New file. * test/lisp/erc/resources/sasl/plain-failed.eld: New file. * test/lisp/erc/resources/sasl/plain.eld: New file. * test/lisp/erc/resources/sasl/scram-sha-1.eld: New file. * test/lisp/erc/resources/sasl/scram-sha-256.eld: New file. * test/lisp/erc/resources/sasl/external.eld: New file. diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi index b9c6e33d36..f86465fed7 100644 --- a/doc/misc/erc.texi +++ b/doc/misc/erc.texi @@ -78,6 +78,7 @@ Top Advanced Usage * Connecting:: Ways of connecting to an IRC server. +* SASL:: Authenticating via SASL. * Sample Configuration:: An example configuration file. * Integrations:: Integrations available for ERC. * Options:: Options that are available for ERC. @@ -482,6 +483,10 @@ Modules @item ring Enable an input history +@cindex modules, sasl +@item sasl +Enable SASL authentication + @cindex modules, scrolltobottom @item scrolltobottom Scroll to the bottom of the buffer @@ -561,6 +566,7 @@ Advanced Usage @menu * Connecting:: Ways of connecting to an IRC server. +* SASL:: Authenticating via SASL * Sample Configuration:: An example configuration file. * Integrations:: Integrations available for ERC. * Options:: Options that are available for ERC. @@ -633,6 +639,7 @@ Connecting parameters, and some, like @code{client-certificate}, will just be @code{nil}. +@anchor{ERC client-certificate} To use a certificate with @code{erc-tls}, specify the optional @var{client-certificate} keyword argument, whose value should be as described in the documentation of @code{open-network-stream}: if @@ -767,7 +774,10 @@ Connecting You can manually set another nickname with the /NICK command. @end defopt +@anchor{ERC username} @subheading User +@cindex user + @defun erc-compute-user &optional user Determine a suitable value to send as the first argument of the opening @samp{USER} IRC command by consulting the following sources: @@ -879,6 +889,7 @@ Connecting @noindent For details, @pxref{Top,,auth-source, auth, Emacs auth-source Library}. +@anchor{ERC auth-source functions} @defopt erc-auth-source-server-function @end defopt @defopt erc-auth-source-services-function @@ -891,7 +902,8 @@ Connecting @code{:user} is the ``desired'' nickname rather than the current one. Generalized names, like @code{:user} and @code{:host}, are always used over back-end specific ones, like @code{:login} or @code{:machine}. -ERC expects a string to use as the secret or nil, if the search fails. +ERC expects a string to use as the secret or @code{nil}, if the search +fails. @findex erc-auth-source-search The default value for all three options is the function @@ -953,6 +965,143 @@ Connecting make the most sense, but any reasonably printable object is acceptable. +@node SASL +@section Authenticating via SASL +@cindex SASL + +Regardless of the mechanism or the network, you'll likely have to be +registered before first use. Please refer to the network's own +instructions for details. If you're new to IRC and using a bouncer, +know that you probably won't be needing SASL for the client-to-bouncer +connection. To get started, just add @code{sasl} to +@code{erc-modules} like any other module. But before that, please +explore all custom options pertaining to your chosen mechanism. + +@defopt erc-sasl-mechanism +The name of an SASL subprotocol type as a @emph{lowercase} symbol. + +@var{plain} and @var{scram} (``password-based''): + +@indentedblock +Here, ``password'' refers to your account password, which is usually +your @samp{NickServ} password. To make this work, customize +@code{erc-sasl-user} and @code{erc-sasl-password} or specify the +@code{:user} and @code{:password} keyword arguments when invoking +@code{erc-tls}. Note that @code{:user} cannot be given interactively. +@end indentedblock + +@var{external} (via Client TLS Certificate): + +@indentedblock +This works in conjunction with the @code{:client-certificate} keyword +offered by @code{erc-tls}. Just ensure you've registered your +fingerprint with the network beforehand. The fingerprint is usually a +SHA1 or SHA256 digest in either "normalized" or "openssl" forms. The +first is lowercase without delims (@samp{deadbeef}) and the second +uppercase with colon seps (@samp{DE:AD:BE:EF}). These days, there's +usually a @samp{CERT ADD} command offered by NickServ that can +register you automatically if you issue it while connected with a +client cert. (@pxref{ERC client-certificate}). + +Additional considerations: +@enumerate +@item +Most IRCds will allow you to authenticate with a client cert but +without the hassle of SASL (meaning you may not need this module). +@item +Technically, @var{EXTERNAL} merely indicates that an out-of-band mode +of authentication is in effect (being deferred to), so depending on +the specific application or service, there's a remote chance your +server has something else in mind. +@end enumerate +@end indentedblock + +@var{ecdsa-nist256p-challenge}: + +@indentedblock +This mechanism is quite complicated and currently requires the +external @samp{openssl} executable, so please use something else if at +all possible. Ignoring that, specify your key file (e.g., +@samp{~/pki/mykey.pem}) as the value of @code{erc-sasl-password}, and +then configure your network settings. On servers running Atheme +services, you can add your public key with @samp{NickServ} like so: + +@example +ERC> /msg NickServ set property \ + pubkey AgGZmlYTUjJlea/BVz7yrjJ6gysiAPaQxzeUzTH4hd5j + +@end example +(You may be able to omit the @samp{property} subcommand.) +@end indentedblock + +@end defopt + +@defopt erc-sasl-user +This should be your network account username, typically the same one +registered with nickname services. Specify this when your NickServ +login differs from the @code{:user} you're connecting with. +(@pxref{ERC username}) +@end defopt + +@defopt erc-sasl-password +As noted elsewhere, the @code{:password} parameter for @code{erc-tls} +was orignally intended for traditional ``server passwords,'' but these +aren't really used any more. As such, this option defaults to +borrowing that parameter for its own uses, thus allowing you to call +@code{erc-tls} with @code{:password} set to your NickServ password. + +You can also set this to a nonemtpy string, and ERC will send that +when needed, no questions asked. If you instead give a non-@code{nil} +symbol (other than @code{:password}), like @samp{Libera.Chat}, ERC +will use it for the @code{:host} field in an auth-source query. +Actually, the same goes for when this option is @code{nil} but an +explicit session ID is already on file (@pxref{Network Identifier}). +For all such queries, ERC specifies the resolved value of +@code{erc-sasl-user} for the @code{:user} (@code{:login}) param. Keep +in mind that none of this matters unless +@code{erc-sasl-auth-source-function} holds a function, and it's +@code{nil} by default. As a last resort, ERC will prompt you for +input. + +Lastly, if your mechanism is @code{ecdsa-nist256p-challenge}, this +option should instead hold the file name of your key. +@end defopt + +@defopt erc-sasl-auth-source-function +This is nearly identical to the other ERC @samp{auth-source} function +options (@pxref{ERC auth-source functions}) except that the default +value here is @code{nil}, meaning you have to set it to something like +@code{erc-auth-source-search} for queries to be performed. +@end defopt + +@defopt erc-sasl-authzid +In the rarest of circumstances, a network may want you to specify a +specific role or assume an alternate identity. In most cases, this +happens because the server is buggy or misconfigured. If you suspect +such a thing, please contact your network operator. Otherwise, just +leave this set to @code{nil}. +@end defopt + +@subheading Troubleshooting + +@strong{Warning:} ERC's SASL offering is currently limited by a lack +of support for proper IRCv3 capability negotiation. In most cases, +this shouldn't affect your ability to authenticate. + +If you're struggling, remember that your SASL password is almost +always your NickServ password. When in doubt, try restoring all SASL +options to their defaults and calling @code{erc-tls} with @code{:user} +set to your NickServ account name and @code{:password} to your +NickServ password. If you're still having trouble, please contact us +(@pxref{Getting Help and Reporting Bugs}). + +As you try out different settings, keep in mind that it's best to +create a fresh session for every change, for example, by calling +@code{erc-tls} from scratch. More experienced users may be able to +get away with cycling @code{erc-sasl-mode} and issuing a +@samp{/reconnect}, but that's generally not recommended. Whatever the +case, you'll probably want to temporarily disable +@code{erc-server-auto-reconnect} while experimenting. @node Sample Configuration @section Sample Configuration diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index 15f7fe84dd..d0d84d0a98 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -48,10 +48,9 @@ hell. For some, auth-source may provide a workaround in the form of nonstandard server passwords. See the "Connection" node in the manual under the subheading "Password". -If you require SASL immediately, please participate in ERC development -by volunteering to try (and give feedback on) edge features, one of -which is SASL. All known external offerings, past and present, are -valiant efforts whose use is nevertheless discouraged. +** Rudimentary SASL support has arrived. +A new module, 'erc-sasl', now ships with ERC 5.5. See the SASL +section in the manual for details. ** Username argument for entry-point commands. Commands 'erc' and 'erc-tls' now accept a ':user' keyword argument, diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 973616bc37..6e91353808 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -2334,6 +2334,15 @@ erc-server-322-message (erc-display-message parsed 'notice 'active 's671 ?n nick ?a securemsg))) +(define-erc-response-handler (900) + "Handle a \"RPL_LOGGEDIN\" server command. +Some servers don't consider this SASL-specific but rather just an +indication of a server-side state change from logged-out to +logged-in." nil + ;; Whenever ERC starts caring about user accounts, it should record + ;; the session as being logged here. + (erc-display-message parsed 'notice proc (erc-response.contents parsed))) + (define-erc-response-handler (431 445 446 451 462 463 464 481 483 484 485 491 501 502) ;; 431 - No nickname given diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el index d23703394b..4893f6ce59 100644 --- a/lisp/erc/erc-compat.el +++ b/lisp/erc/erc-compat.el @@ -273,6 +273,89 @@ erc-compat--auth-source-backend-parser-functions auth-source-backend-parser-functions)) +;;;; SASL + +(declare-function sasl-step-data "sasl" (step)) +(declare-function sasl-error "sasl" (datum)) +(declare-function sasl-client-property "sasl" (client property)) +(declare-function sasl-client-set-property "sasl" (client property value)) +(declare-function sasl-mechanism-name "sasl" (mechanism)) +(declare-function sasl-client-name "sasl" (client)) +(declare-function sasl-client-mechanism "sasl" (client)) +(declare-function sasl-read-passphrase "sasl" (prompt)) +(declare-function sasl-unique-id "sasl" nil) +(declare-function decode-hex-string "hex-util" (string)) +(declare-function rfc2104-hash "rfc2104" (hash block-length hash-length + key text)) +(declare-function sasl-scram--client-first-message-bare "sasl-scram-rfc" + (client)) +(declare-function cl-mapcar "cl-lib" (cl-func cl-x &rest cl-rest)) + +(defun erc-compat--29-sasl-scram-construct-gs2-header (client) + (let ((authzid (sasl-client-property client 'authenticator-name))) + (concat "n," (and authzid "a=") authzid ","))) + +(defun erc-compat--29-sasl-scram-client-first-message (client _step) + (let ((c-nonce (sasl-unique-id))) + (sasl-client-set-property client 'c-nonce c-nonce)) + (concat (erc-compat--29-sasl-scram-construct-gs2-header client) + (sasl-scram--client-first-message-bare client))) + +(defun erc-compat--29-sasl-scram--client-final-message + (hash-fun block-length hash-length client step) + (unless (string-match + "^r=\\([^,]+\\),s=\\([^,]+\\),i=\\([0-9]+\\)\\(?:$\\|,\\)" + (sasl-step-data step)) + (sasl-error "Unexpected server response")) + (let* ((hmac-fun + (lambda (text key) + (decode-hex-string + (rfc2104-hash hash-fun block-length hash-length key text)))) + (step-data (sasl-step-data step)) + (nonce (match-string 1 step-data)) + (salt-base64 (match-string 2 step-data)) + (iteration-count (string-to-number (match-string 3 step-data))) + (c-nonce (sasl-client-property client 'c-nonce)) + (cbind-input + (if (string-prefix-p c-nonce nonce) + (erc-compat--29-sasl-scram-construct-gs2-header client) ; *1 + (sasl-error "Invalid nonce from server"))) + (client-final-message-without-proof + (concat "c=" (base64-encode-string cbind-input t) "," ; *2 + "r=" nonce)) + (password + (sasl-read-passphrase + (format "%s passphrase for %s: " + (sasl-mechanism-name (sasl-client-mechanism client)) + (sasl-client-name client)))) + (salt (base64-decode-string salt-base64)) + (string-xor (lambda (a b) + (apply #'unibyte-string (cl-mapcar #'logxor a b)))) + (salted-password (let ((digest (concat salt (string 0 0 0 1))) + (xored nil)) + (dotimes (_i iteration-count xored) + (setq digest (funcall hmac-fun digest password)) + (setq xored (if (null xored) + digest + (funcall string-xor xored + digest)))))) + (client-key (funcall hmac-fun "Client Key" salted-password)) + (stored-key (decode-hex-string (funcall hash-fun client-key))) + (auth-message (concat "n=" (sasl-client-name client) + ",r=" c-nonce "," step-data + "," client-final-message-without-proof)) + (client-signature (funcall hmac-fun + (encode-coding-string auth-message 'utf-8) + stored-key)) + (client-proof (funcall string-xor client-key client-signature)) + (client-final-message + (concat client-final-message-without-proof "," + "p=" (base64-encode-string client-proof t)))) ; *3 + (sasl-client-set-property client 'auth-message auth-message) + (sasl-client-set-property client 'salted-password salted-password) + client-final-message)) + + ;;;; Misc 29.1 (defmacro erc-compat--with-memoization (table &rest forms) diff --git a/lisp/erc/erc-sasl.el b/lisp/erc/erc-sasl.el new file mode 100644 index 0000000000..ab171ea4d3 --- /dev/null +++ b/lisp/erc/erc-sasl.el @@ -0,0 +1,417 @@ +;;; erc-sasl.el --- SASL for ERC -*- lexical-binding: t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published +;; by the Free Software Foundation, either version 3 of the License, +;; or (at your option) any later version. +;; +;; GNU Emacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; This "non-IRCv3" implementation resembles others that have surfaced +;; over the years, the first possibly being from Joseph Gay: +;; +;; https://lists.gnu.org/archive/html/erc-discuss/2012-02/msg00001.html +;; +;; See options and Info manual for usage. +;; +;; TODO: +;; +;; - Find a way to obfuscate the password in memory (via something +;; like `auth-source--obfuscate'); it's currently visible in +;; backtraces. +;; +;; - Implement a proxy mechanism that chooses the strongest available +;; mechanism for you. Requires CAP 3.2 (see bug#49860). +;; +;; - Integrate with whatever solution ERC eventually settles on to +;; handle user options for different network contexts. At the +;; moment, this does its own thing for stashing and restoring +;; session options, but ERC should make abstractions available for +;; all local modules to use, possibly based on connection-local +;; variables. + +;;; Code: +(require 'erc) +(require 'rx) +(require 'sasl) +(require 'sasl-scram-rfc) +(require 'sasl-scram-sha256 nil t) ; not present in Emacs 27 + +(defgroup erc-sasl nil + "SASL for ERC." + :group 'erc + :package-version '(ERC . "5.4.1")) ; FIXME increment on next release + +(defcustom erc-sasl-mechanism 'plain + "SASL mechanism to connect with. +Note that any value other than nil or `external' likely requires +`erc-sasl-user' and `erc-sasl-password'." + :type '(choice (const plain) + (const external) + (const scram-sha-1) + (const scram-sha-256) + (const scram-sha-512) + (const ecdsa-nist256p-challenge))) + +(defcustom erc-sasl-user :user + "Account username to send when authenticating. +This is also referred to as the authentication identity or +\"authcid\". A value of `:user' or `:nick' indicates that the +corresponding connection parameter on file should be used. These +are most often derived from arguments provided to the `erc' and +`erc-tls' entry points. In the case of `:nick', a downcased +version is used." + :type '(choice string (const :user) (const :nick))) + +(defcustom erc-sasl-password :password + "Optional account password to send when authenticating. +When the value is a string, ERC will use it unconditionally for +most mechanisms. Likewise with `:password', except ERC will +instead use the \"session password\" on file, which often +originates from the entry-point commands `erc' or `erc-tls'. +Otherwise, when `erc-sasl-auth-source-function' is a function, +ERC will attempt an auth-source query, possibly using a non-nil +symbol for the suggested `:host' parameter if set as this +option's value or passed as an `:id' to `erc-tls'. Failing that, +ERC will prompt for input. + +Note that, with `:password', ERC will forgo sending a traditional +server password via the IRC \"PASS\" command. Also, when +`erc-sasl-mechanism' is set to `ecdsa-nist256p-challenge', this +option should hold the file name of the key." + :type '(choice (const nil) (const :password) string symbol)) + +(defcustom erc-sasl-auth-source-function nil + "Function to query auth-source for an SASL password. +Called with keyword params known to `auth-source-search', which +includes `erc-sasl-user' for the `:user' field and +`erc-sasl-password' for the `:host' field, when the latter option +is a non-nil, non-keyword symbol. In return, ERC expects a +string to send as the SASL password, or nil, to move on to the +next approach, as described in the doc string for the option +`erc-sasl-password'. See info node `(erc) Connecting' for +details on ERC's auth-source integration." + :type '(choice (function-item erc-auth-source-search) + (const nil) + function)) + +(defcustom erc-sasl-authzid nil + "SASL authorization identity, likely unneeded for everyday use." + :type '(choice (const nil) string)) + + +;; Analogous to what erc-backend does to persist opening params. +(defvar-local erc-sasl--options nil) + +;; Session-local (server buffer) SASL subproto state +(defvar-local erc-sasl--state nil) + +(cl-defstruct erc-sasl--state + "Holder for client object and subproto state." + (client nil :type vector) + (step nil :type vector) + (pending nil :type string)) + +(defun erc-sasl--get-user () + (pcase (alist-get 'user erc-sasl--options) + (:user erc-session-username) + (:nick (erc-downcase (erc-current-nick))) + (v v))) + +(defun erc-sasl--read-password (prompt) + "Return configured option or server password. +PROMPT is passed to `read-passwd' if necessary." + (if-let + ((found (pcase (alist-get 'password erc-sasl--options) + (:password erc-session-password) + ((and (pred stringp) v) (unless (string-empty-p v) v)) + ((and (guard erc-sasl-auth-source-function) + v (let host + (or v (erc-networks--id-given erc-networks--id)))) + (apply erc-sasl-auth-source-function + :user (erc-sasl--get-user) + (and host (list :host (symbol-name host)))))))) + (copy-sequence found) + (read-passwd prompt))) + +(defun erc-sasl--plain-response (client steps) + (let ((sasl-read-passphrase #'erc-sasl--read-password)) + (sasl-plain-response client steps))) + +(declare-function erc-compat--29-sasl-scram--client-final-message "erc-compat" + (hash-fun block-length hash-length client step)) + +(defun erc-sasl--scram-sha-hack-client-final-message (&rest args) + ;; In the future (29+), we'll hopefully be able to call + ;; `sasl-scram--client-final-message' directly + (require 'erc-compat) + (let ((sasl-read-passphrase #'erc-sasl--read-password)) + (apply #'erc-compat--29-sasl-scram--client-final-message args))) + +(defun erc-sasl--scram-sha-1-client-final-message (client step) + (erc-sasl--scram-sha-hack-client-final-message 'sha1 64 20 client step)) + +(defun erc-sasl--scram-sha-256-client-final-message (client step) + (erc-sasl--scram-sha-hack-client-final-message 'sasl-scram-sha256 64 32 + client step)) + +(defun erc-sasl--scram-sha512 (object &optional start end binary) + (secure-hash 'sha512 object start end binary)) + +(defun erc-sasl--scram-sha-512-client-final-message (client step) + (erc-sasl--scram-sha-hack-client-final-message #'erc-sasl--scram-sha512 + 128 64 client step)) + +(defun erc-sasl--scram-sha-512-authenticate-server (client step) + (sasl-scram--authenticate-server #'erc-sasl--scram-sha512 + 128 64 client step)) + +(defun erc-sasl--ecdsa-first (client _step) + "Return CLIENT name." + (sasl-client-name client)) + +;; FIXME do this with gnutls somehow +(defun erc-sasl--ecdsa-sign (client step) + "Return signed challenge for CLIENT and current STEP." + (let ((challenge (sasl-step-data step))) + (with-temp-buffer + (set-buffer-multibyte nil) + (insert challenge) + (call-process-region (point-min) (point-max) + "openssl" 'delete t nil "pkeyutl" "-inkey" + (sasl-client-property client 'ecdsa-keyfile) + "-sign") + (buffer-string)))) + +(pcase-dolist + (`(,name . ,steps) + '(("PLAIN" + erc-sasl--plain-response) + ("EXTERNAL" + ignore) + ("SCRAM-SHA-1" + erc-compat--29-sasl-scram-client-first-message + erc-sasl--scram-sha-1-client-final-message + sasl-scram-sha-1-authenticate-server) + ("SCRAM-SHA-256" + erc-compat--29-sasl-scram-client-first-message + erc-sasl--scram-sha-256-client-final-message + sasl-scram-sha-256-authenticate-server) + ("SCRAM-SHA-512" + erc-compat--29-sasl-scram-client-first-message + erc-sasl--scram-sha-512-client-final-message + erc-sasl--scram-sha-512-authenticate-server) + ("ECDSA-NIST256P-CHALLENGE" + erc-sasl--ecdsa-first + erc-sasl--ecdsa-sign))) + (let ((feature (intern (concat "erc-sasl-" (downcase name))))) + (put feature 'sasl-mechanism (sasl-make-mechanism name steps)) + (provide feature))) + +(cl-defgeneric erc-sasl--create-client (mechanism) + "Create and return a new SASL client object for MECHANISM." + (let ((sasl-mechanism-alist (copy-sequence sasl-mechanism-alist)) + (sasl-mechanisms sasl-mechanisms) + (name (upcase (symbol-name mechanism))) + (feature (intern-soft (concat "erc-sasl-" (symbol-name mechanism)))) + client) + (when feature + (setf (alist-get name sasl-mechanism-alist nil nil #'equal) `(,feature)) + (cl-pushnew name sasl-mechanisms :test #'equal) + (setq client (sasl-make-client (sasl-find-mechanism (list name)) + (erc-sasl--get-user) + "N/A" "N/A")) + (sasl-client-set-property client 'authenticator-name + (alist-get 'authzid erc-sasl--options)) + client))) + +(cl-defmethod erc-sasl--create-client ((_ (eql plain))) + "Create and return a new PLAIN client object." + ;; https://tools.ietf.org/html/rfc4616#section-2. + (let* ((sans (remq (assoc "PLAIN" sasl-mechanism-alist) + sasl-mechanism-alist)) + (sasl-mechanism-alist (cons '("PLAIN" erc-sasl-plain) sans)) + (authc (erc-sasl--get-user)) + (port (if (numberp erc-session-port) + (number-to-string erc-session-port) + "0")) + ;; In most cases, `erc-server-announced-name' won't be known. + (host (or erc-server-announced-name erc-session-server)) + (mech (sasl-find-mechanism '("PLAIN"))) + (client (sasl-make-client mech authc port host))) + (sasl-client-set-property client 'authenticator-name + (alist-get 'authzid erc-sasl--options)) + client)) + +(cl-defmethod erc-sasl--create-client ((_ (eql scram-sha-256))) + "Create and return a new SCRAM-SHA-256 client." + (when (featurep 'sasl-scram-sha256) + (cl-call-next-method))) + +(cl-defmethod erc-sasl--create-client ((_ (eql scram-sha-512))) + "Create and return a new SCRAM-SHA-512 client." + (when (featurep 'sasl-scram-sha256) + (cl-call-next-method))) + +(cl-defmethod erc-sasl--create-client ((_ (eql ecdsa-nist256p-challenge))) + "Create and return a new ECDSA-NIST256P-CHALLENGE client." + (let ((keyfile (cdr (assq 'password erc-sasl--options)))) + ;; Better to signal usage errors now than inside a process filter. + (cond ((or (not (stringp keyfile)) (not (file-readable-p keyfile))) + (erc-display-error-notice + nil "`erc-sasl-password' not accessible as a file") + nil) + ((not (executable-find "openssl")) + (erc-display-error-notice nil "Could not find openssl program") + nil) + (t + (let ((client (cl-call-next-method))) + (sasl-client-set-property client 'ecdsa-keyfile keyfile) + client))))) + +;; This stands alone because it's also used by bug#49860. +(defun erc-sasl--init () + (setq erc-sasl--state (make-erc-sasl--state)) + ;; If the previous attempt failed during registration, this may be + ;; non-nil and contain erroneous values, but how can we detect that? + ;; What if the server dropped the connection for some other reason? + (setq erc-sasl--options + (or (and erc--server-reconnecting + (alist-get 'erc-sasl--options erc--server-reconnecting)) + `((user . ,erc-sasl-user) + (password . ,erc-sasl-password) + (mechanism . ,erc-sasl-mechanism) + (authzid . ,erc-sasl-authzid))))) + +(defun erc-sasl--mechanism-offered-p (offered) + "Return non-nil when OFFERED appears among a list of mechanisms." + (string-match-p (rx-to-string + `(: (| bot ",") + ,(symbol-name (alist-get 'mechanism erc-sasl--options)) + (| eot ","))) + (downcase offered))) + +(erc-define-catalog + 'english + '((s902 . "ERR_NICKLOCKED nick %n unavailable: %s") + (s904 . "ERR_SASLFAIL (authentication failed) %s") + (s905 . "ERR SASLTOOLONG (credentials too long) %s") + (s906 . "ERR_SASLABORTED (authentication aborted) %s") + (s907 . "ERR_SASLALREADY (already authenticated) %s") + (s908 . "RPL_SASLMECHS (unsupported mechanism: %m) %s"))) + +(define-erc-module sasl nil + "Non-IRCv3 SASL support for ERC. +This doesn't solicit or validate a suite of supported mechanisms." + ;; See bug#49860 for a CAP 3.2-aware WIP implementation. + ((unless erc--target + (erc-sasl--init) + (let* ((mech (alist-get 'mechanism erc-sasl--options)) + (client (erc-sasl--create-client mech))) + (unless client + (erc-display-error-notice + nil (format "Unknown or unsupported SASL mechanism: %s" mech)) + (erc-error "Unknown or unsupported SASL mechanism: %s" mech)) + (setf (erc-sasl--state-client erc-sasl--state) client)))) + ((kill-local-variable 'erc-sasl--state) + (kill-local-variable 'erc-sasl--options)) + 'local) + +(define-erc-response-handler (AUTHENTICATE) + "Begin or resume an SASL session." nil + (if-let* ((response (car (erc-response.command-args parsed))) + ((= 400 (length response)))) + (cl-callf (lambda (s) (concat s response)) + (erc-sasl--state-pending erc-sasl--state)) + (cl-assert response t) + (when (string= "+" response) + (setq response "")) + (setf response (base64-decode-string + (concat (erc-sasl--state-pending erc-sasl--state) + response)) + (erc-sasl--state-pending erc-sasl--state) nil) + (let ((client (erc-sasl--state-client erc-sasl--state)) + (step (erc-sasl--state-step erc-sasl--state)) + data) + (when step + (sasl-step-set-data step response)) + (setq step (setf (erc-sasl--state-step erc-sasl--state) + (sasl-next-step client step)) + data (sasl-step-data step)) + (when (string= data "") + (setq data nil)) + (when data + (setq data (base64-encode-string data t))) + (erc-server-send (concat "AUTHENTICATE " (or data "+")))))) + +(defun erc-sasl--destroy (proc) + (run-hook-with-args 'erc-quit-hook proc) + (delete-process proc) + (erc-error "Disconnected from %s; please review SASL settings" proc)) + +(define-erc-response-handler (902) + "Handle an ERR_NICKLOCKED response." nil + (erc-display-message parsed '(notice error) 'active 's902 + ?n (car (erc-response.command-args parsed)) + ?s (erc-response.contents parsed)) + (erc-sasl--destroy proc)) + +(define-erc-response-handler (903) + "Handle a RPL_SASLSUCCESS response." nil + (when erc-sasl-mode + (unless erc-server-connected + (erc-server-send "CAP END"))) + (erc-display-message parsed 'notice proc (erc-response.contents parsed))) + +(define-erc-response-handler (907) + "Handle a RPL_SASLALREADY response." nil + (erc-display-message parsed '(notice error) 'active 's907 + ?s (erc-response.contents parsed))) + +(define-erc-response-handler (904 905 906) + "Handle various SASL-related error responses." nil + (erc-display-message parsed '(notice error) 'active + (intern (format "s%s" (erc-response.command parsed))) + ?s (erc-response.contents parsed)) + (erc-sasl--destroy proc)) + +(define-erc-response-handler (908) + "Handle a RPL_SASLALREADY response." nil + (erc-display-message parsed '(notice error) 'active 's908 + ?m (alist-get 'mechanism erc-sasl--options) + ?s (string-join (cdr (erc-response.command-args parsed)) + " ")) + (erc-sasl--destroy proc)) + +(cl-defmethod erc--register-connection (&context (erc-sasl-mode (eql t))) + "Send speculative/pipelined CAP and AUTHENTICATE and hope for the best." + (if-let* ((c (erc-sasl--state-client erc-sasl--state)) + (m (sasl-mechanism-name (sasl-client-mechanism c)))) + (progn + (erc-server-send "CAP REQ :sasl") + (if (and erc-session-password + (eq :password (alist-get 'password erc-sasl--options))) + (let (erc-session-password) + (erc-login)) + (erc-login)) + (erc-server-send (format "AUTHENTICATE %s" m))) + (erc-sasl--destroy erc-server-process))) + +(provide 'erc-sasl) +;;; erc-sasl.el ends here +;; +;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" +;; End: diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 384d92e624..63093d509b 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -1860,6 +1860,7 @@ erc-modules (const :tag "readonly: Make displayed lines read-only" readonly) (const :tag "replace: Replace text in messages" replace) (const :tag "ring: Enable an input history" ring) + (const :tag "sasl: Enable SASL authentication" sasl) (const :tag "scrolltobottom: Scroll to the bottom of the buffer" scrolltobottom) (const :tag "services: Identify to Nickserv (IRC Services) automatically" diff --git a/test/lisp/erc/erc-sasl-tests.el b/test/lisp/erc/erc-sasl-tests.el new file mode 100644 index 0000000000..64593ca270 --- /dev/null +++ b/test/lisp/erc/erc-sasl-tests.el @@ -0,0 +1,344 @@ +;;; erc-sasl-tests.el --- Tests for erc-sasl. -*- lexical-binding:t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert-x) +(require 'erc-sasl) + +(ert-deftest erc-sasl--mechanism-offered-p () + (let ((erc-sasl--options '((mechanism . external)))) + (should (erc-sasl--mechanism-offered-p "foo,external")) + (should (erc-sasl--mechanism-offered-p "external,bar")) + (should (erc-sasl--mechanism-offered-p "foo,external,bar")) + (should-not (erc-sasl--mechanism-offered-p "fooexternal")) + (should-not (erc-sasl--mechanism-offered-p "externalbar")))) + +(ert-deftest erc-sasl--read-password--basic () + (ert-info ("Explicit erc-sasl-password") + (let ((erc-sasl--options '((password . "foo")))) + (should (string= (erc-sasl--read-password nil) "foo")))) + + (ert-info ("Explicit session password") + (let ((erc-session-password "foo") + (erc-sasl--options '((password . :password)))) + (should (string= (erc-sasl--read-password nil) "foo")))) + + (ert-info ("Fallback to prompt skip auth-source") + (should-not erc-sasl-auth-source-function) + (let ((erc-session-password "bar") + (erc-networks--id (erc-networks--id-create nil))) + (should (string= (ert-simulate-keys "bar\r" + (erc-sasl--read-password "?")) + "bar")))) + + (ert-info ("Prompt when auth-source fails and `erc-sasl-password' null") + (let ((erc-sasl--options '((password))) + (erc-sasl-auth-source-function #'ignore)) + (should (string= (ert-simulate-keys "baz\r" + (erc-sasl--read-password "pwd:")) + "baz"))))) + +(ert-deftest erc-sasl--read-password--auth-source () + (ert-with-temp-file netrc-file + :text (string-join + (list + ;; If you swap these first 2 lines, *1 below fails + "machine FSF.chat port 6697 user bob password sesame" + "machine GNU/chat port 6697 user bob password spam" + "machine MyHost port irc password 123") + "\n") + (let* ((auth-sources (list netrc-file)) + (erc-session-server "irc.gnu.org") + (erc-session-port 6697) + (erc-networks--id (erc-networks--id-create nil)) + calls + (erc-sasl-auth-source-function + (lambda (&rest r) + (push r calls) + (apply #'erc--auth-source-search r))) + erc-server-announced-name ; too early + auth-source-do-cache) + + (ert-info ("Symbol as password specifies machine") + (let ((erc-sasl--options '((user . "bob") (password . FSF.chat))) + (erc-networks--id (make-erc-networks--id))) + (should (string= (erc-sasl--read-password nil) "sesame")) + (should (equal (pop calls) '(:user "bob" :host "FSF.chat"))))) + + (ert-info ("ID for :host and `erc-session-username' for :user") ; *1 + (let ((erc-session-username "bob") + (erc-sasl--options '((user . :user) (password))) + (erc-networks--id (erc-networks--id-create 'GNU/chat))) + (should (string= (erc-sasl--read-password nil) "spam")) + (should (equal (pop calls) '(:user "bob" :host "GNU/chat"))))) + + (ert-info ("ID for :host and current nick for :user") ; *1 + (let ((erc-server-current-nick "bob") + (erc-sasl--options '((user . :nick) (password))) + (erc-networks--id (erc-networks--id-create 'GNU/chat))) + (should (string= (erc-sasl--read-password nil) "spam")) + (should (equal (pop calls) '(:user "bob" :host "GNU/chat"))))) + + (ert-info ("Symbol as password, entry lacks user field") + (let ((erc-server-current-nick "fake") + (erc-sasl--options '((user . :nick) (password . MyHost))) + (erc-networks--id (erc-networks--id-create 'GNU/chat))) + (should (string= (erc-sasl--read-password nil) "123")) + (should (equal (pop calls) '(:user "fake" :host "MyHost")))))))) + +(ert-deftest erc-sasl-create-client--plain () + (let* ((erc-session-password "password123") + (erc-session-username "tester") + (erc-sasl--options '((user . :user) (password . :password))) + (erc-session-port 1667) + (erc-session-server "localhost") + (client (erc-sasl--create-client 'plain)) + (result (sasl-next-step client nil))) + (should (equal (format "%S" [erc-sasl--plain-response + "\0tester\0password123"]) + (format "%S" result))) + (should (string= (sasl-step-data result) "\0tester\0password123")) + (should-not (sasl-next-step client result))) + (should (equal (assoc-default "PLAIN" sasl-mechanism-alist) '(sasl-plain)))) + +(ert-deftest erc-sasl-create-client--external () + (let* ((erc-server-current-nick "tester") + (erc-sasl--options '((user . :nick) (password . :password))) + (client (erc-sasl--create-client 'external)) ; unused ^ + (result (sasl-next-step client nil))) + (should (equal (format "%S" [ignore nil]) (format "%S" result))) + (should-not (sasl-step-data result)) + (should-not (sasl-next-step client result))) + (should-not (member "EXTERNAL" sasl-mechanisms)) + (should-not (assoc-default "EXTERNAL" sasl-mechanism-alist))) + +(ert-deftest erc-sasl-create-client--scram-sha-1 () + (let* ((erc-sasl--options '((user . "jilles") (password . "sesame") + (authzid . "jilles"))) + (mock-rvs (list "c5RqLCZy0L4fGkKAZ0hujFBs" "")) + (sasl-unique-id-function (lambda () (pop mock-rvs))) + (client (erc-sasl--create-client 'scram-sha-1)) + (step (sasl-next-step client nil))) + (ert-info ("Client's initial request") + (let ((req "n,a=jilles,n=jilles,r=c5RqLCZy0L4fGkKAZ0hujFBs")) + (should (equal (format "%S" + `[erc-compat--29-sasl-scram-client-first-message + ,req]) + (format "%S" step))) + (should (string= (sasl-step-data step) req)))) + (ert-info ("Server's initial response") + (let ((resp (concat "r=c5RqLCZy0L4fGkKAZ0hujFBsXQoKcivqCw9iDZPSpb," + "s=5mJO6d4rjCnsBU1X," + "i=4096")) + (req (concat "c=bixhPWppbGxlcyw=," + "r=c5RqLCZy0L4fGkKAZ0hujFBsXQoKcivqCw9iDZPSpb," + "p=OVUhgPu8wEm2cDoVLfaHzVUYPWU="))) + (sasl-step-set-data step resp) + (setq step (sasl-next-step client step)) + (should (equal (format "%S" + `[erc-sasl--scram-sha-1-client-final-message + ,req]) + (format "%S" step))) + (should (string= (sasl-step-data step) req)))) + (ert-info ("Server's final message") + (let ((resp "v=ZWR23c9MJir0ZgfGf5jEtLOn6Ng=")) + (sasl-step-set-data step resp) + (setq step (sasl-next-step client step)) + (should-not (sasl-step-data step))))) + (should (eq sasl-unique-id-function #'sasl-unique-id-function))) + +(ert-deftest erc-sasl-create-client--scram-sha-256 () + (unless (featurep 'sasl-scram-sha256) + (ert-skip "Emacs lacks sasl-scram-sha256")) + (let* ((erc-server-current-nick "jilles") + (erc-session-password "sesame") + (erc-sasl--options '((user . :nick) (password . :password) + (authzid . "jilles"))) + (mock-rvs (list "c5RqLCZy0L4fGkKAZ0hujFBs" "")) + (sasl-unique-id-function (lambda () (pop mock-rvs))) + (client (erc-sasl--create-client 'scram-sha-256)) + (step (sasl-next-step client nil))) + (ert-info ("Client's initial request") + (let ((req "n,a=jilles,n=jilles,r=c5RqLCZy0L4fGkKAZ0hujFBs")) + (should (equal (format "%S" + `[erc-compat--29-sasl-scram-client-first-message + ,req]) + (format "%S" step))) + (should (string= (sasl-step-data step) req)))) + (ert-info ("Server's initial response") + (let ((resp (concat + "r=c5RqLCZy0L4fGkKAZ0hujFBse697140729d8445fb95ec94ceacb14b3," + "s=MTk2M2VkMzM5ZmU0NDRiYmI0MzIyOGVhN2YwNzYwNmI=," + "i=4096")) + (req (concat + "c=bixhPWppbGxlcyw=," + "r=c5RqLCZy0L4fGkKAZ0hujFBse697140729d8445fb95ec94ceacb14b3," + "p=1vDesVBzJmv0lX0Ae1kHFtdVHkC6j4gISKVqaR45HFg="))) + (sasl-step-set-data step resp) + (setq step (sasl-next-step client step)) + (should (equal (format "%S" + `[erc-sasl--scram-sha-256-client-final-message + ,req]) + (format "%S" step))) + (should (string= (sasl-step-data step) req)))) + (ert-info ("Server's final message") + (let ((resp "v=gUePTYSZN9xgcE06KSyKO9fUmSwH26qifoapXyEs75s=")) + (sasl-step-set-data step resp) + (setq step (sasl-next-step client step)) + (should-not (sasl-step-data step))))) + (should (eq sasl-unique-id-function #'sasl-unique-id-function))) + +(ert-deftest erc-sasl-create-client--scram-sha-256--no-authzid () + (unless (featurep 'sasl-scram-sha256) + (ert-skip "Emacs lacks sasl-scram-sha256")) + (let* ((erc-server-current-nick "jilles") + (erc-session-password "sesame") + (erc-sasl--options '((user . :nick) (password . :password) (authzid))) + (mock-rvs (list "c5RqLCZy0L4fGkKAZ0hujFBs" "")) + (sasl-unique-id-function (lambda () (pop mock-rvs))) + (client (erc-sasl--create-client 'scram-sha-256)) + (step (sasl-next-step client nil))) + (ert-info ("Client's initial request") + (let ((req "n,,n=jilles,r=c5RqLCZy0L4fGkKAZ0hujFBs")) + (should (equal (format "%S" + `[erc-compat--29-sasl-scram-client-first-message + ,req]) + (format "%S" step))) + (should (string= (sasl-step-data step) req)))) + (ert-info ("Server's initial response") + (let ((resp (concat + "r=c5RqLCZy0L4fGkKAZ0hujFBsd4067f0afdb54c3dbd4fe645b84cae37," + "s=ZTg1MmE1YmFhZGI1NDcyMjk3NzYwZmRjZDM3Y2I1OTM=," + "i=4096")) + (req (concat + "c=biws," + "r=c5RqLCZy0L4fGkKAZ0hujFBsd4067f0afdb54c3dbd4fe645b84cae37," + "p=LP4sjJrjJKp5qTsARyZCppXpKLu4FMM284hNESPvGhI="))) + (sasl-step-set-data step resp) + (setq step (sasl-next-step client step)) + (should (equal (format "%S" + `[erc-sasl--scram-sha-256-client-final-message + ,req]) + (format "%S" step))) + (should (string= (sasl-step-data step) req)))) + (ert-info ("Server's final message") + (let ((resp "v=847WXfnmReGyE1qlq1And6R4bPBNROTZ7EMS/QrJtUM=")) + (sasl-step-set-data step resp) + (setq step (sasl-next-step client step)) + (should-not (sasl-step-data step))))) + (should (eq sasl-unique-id-function #'sasl-unique-id-function))) + +(ert-deftest erc-sasl-create-client--scram-sha-512--no-authzid () + (unless (featurep 'sasl-scram-sha256) + (ert-skip "Emacs lacks sasl-scram-sha512")) + (let* ((erc-server-current-nick "jilles") + (erc-session-password "sesame") + (erc-sasl--options '((user . :nick) (password . :password) (authzid))) + (mock-rvs (list "c5RqLCZy0L4fGkKAZ0hujFBs" "")) + (sasl-unique-id-function (lambda () (pop mock-rvs))) + (client (erc-sasl--create-client 'scram-sha-512)) + (step (sasl-next-step client nil))) + (ert-info ("Client's initial request") + (let ((req "n,,n=jilles,r=c5RqLCZy0L4fGkKAZ0hujFBs")) + (should (equal (format "%S" + `[erc-compat--29-sasl-scram-client-first-message + ,req]) + (format "%S" step))) + (should (string= (sasl-step-data step) req)))) + (ert-info ("Server's initial response") + (let ((resp (concat + "r=c5RqLCZy0L4fGkKAZ0hujFBs54c592745ce14e559fcc3f27b15464f6," + "s=YzMzOWZiY2U0YzcwNDA0M2I4ZGE2M2ZjOTBjODExZTM=," + "i=4096")) + (req (concat + "c=biws," + "r=c5RqLCZy0L4fGkKAZ0hujFBs54c592745ce14e559fcc3f27b15464f6," + "p=vMBb9tKxFAfBtel087/GLbo4objAIYr1wM+mFv/jYLKXE" + "NUF0vynm81qQbywQE5ScqFFdAfwYMZq/lj4s0V1OA=="))) + (sasl-step-set-data step resp) + (setq step (sasl-next-step client step)) + (should (equal (format + "%S" `[erc-sasl--scram-sha-512-client-final-message + ,req]) + (format "%S" step))) + (should (string= (sasl-step-data step) req)))) + (ert-info ("Server's final message") + (let ((resp (concat "v=Va7NIvt8wCdhvxnv+bZriSxGoto6On5EVnRHO/ece8zs0" + "qpQassdqir1Zlwh3e3EmBq+kcSy+ClNCsbzBpXe/w=="))) + (sasl-step-set-data step resp) + (setq step (sasl-next-step client step)) + (should-not (sasl-step-data step))))) + (should (eq sasl-unique-id-function #'sasl-unique-id-function))) + +(defconst erc-sasl-tests-ecdsa-key-file " +-----BEGIN EC PARAMETERS----- +BggqhkjOPQMBBw== +-----END EC PARAMETERS----- +-----BEGIN EC PRIVATE KEY----- +MHcCAQEEIIJueQ3W2IrGbe9wKdOI75yGS7PYZSj6W4tg854hlsvmoAoGCCqGSM49 +AwEHoUQDQgAEAZmaVhNSMmV5r8FXPvKuMnqDKyIA9pDHN5TNMfiF3mMeikGgK10W +IRX9cyi2wdYg9mUUYyh9GKdBCYHGUJAiCA== +-----END EC PRIVATE KEY----- +") + +(ert-deftest erc-sasl-create-client-ecdsa () + :tags '(:unstable) + ;; This is currently useless because it just roundtrips shelling out + ;; to pkeyutl. + (ert-skip "Placeholder") + (unless (executable-find "openssl") + (ert-skip "System lacks openssl")) + (ert-with-temp-file keyfile + :prefix "ecdsa_key" + :suffix ".pem" + :text erc-sasl-tests-ecdsa-key-file + (let* ((erc-server-current-nick "jilles") + (erc-sasl--options `((password . ,keyfile))) + (client (erc-sasl--create-client 'ecdsa-nist256p-challenge)) + (step (sasl-next-step client nil))) + (ert-info ("Client's initial request") + (should (equal (format "%S" [erc-sasl--ecdsa-first "jilles"]) + (format "%S" step))) + (should (string= (sasl-step-data step) "jilles"))) + (ert-info ("Server's initial response") + (let ((resp (concat "\0\1\2\3\4\5\6\7\10\11\12\13\14\15\16\17\20" + "\21\22\23\24\25\26\27\30\31\32\33\34\35\36\37"))) + (sasl-step-set-data step resp) + (setq step (sasl-next-step client step)) + (ert-with-temp-file sigfile + :prefix "ecdsa_sig" + :suffix ".sig" + :text (sasl-step-data step) + (with-temp-buffer + (set-buffer-multibyte nil) + (insert resp) + (let ((ec (call-process-region + (point-min) (point-max) + "openssl" 'delete t nil "pkeyutl" + "-inkey" keyfile "-sigfile" sigfile + "-verify"))) + (unless (zerop ec) + (message "%s" (buffer-string))) + (should (zerop ec))))))) + (should-not (sasl-next-step client step))))) + +;;; erc-sasl-tests.el ends here diff --git a/test/lisp/erc/erc-scenarios-sasl.el b/test/lisp/erc/erc-scenarios-sasl.el new file mode 100644 index 0000000000..6c5e78d0c8 --- /dev/null +++ b/test/lisp/erc/erc-scenarios-sasl.el @@ -0,0 +1,144 @@ +;;; erc-scenarios-sasl.el --- SASL tests for ERC -*- lexical-binding: t -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. +;; +;; This file is part of GNU Emacs. +;; +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see +;; . + +;;; Code: + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +(require 'erc-sasl) + +(ert-deftest erc-scenarios-sasl--plain () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "sasl") + (erc-server-flood-penalty 0.1) + (dumb-server (erc-d-run "localhost" t 'plain)) + (port (process-contact dumb-server :service)) + (erc-modules (cons 'sasl erc-modules)) + (erc-sasl-password "password123") + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :user "tester" + :full-name "tester") + (should (string= (buffer-name) (format "127.0.0.1:%d" port))))) + + (ert-info ("Notices received") + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "ExampleOrg")) + (funcall expect 10 "This server is in debug mode") + ;; Regression "\0\0\0\0 ..." caused by (fillarray passphrase 0) + (should (string= erc-sasl-password "password123")))))) + +(ert-deftest erc-scenarios-sasl--external () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "sasl") + (erc-server-flood-penalty 0.1) + (dumb-server (erc-d-run "localhost" t 'external)) + (port (process-contact dumb-server :service)) + (erc-modules (cons 'sasl erc-modules)) + (erc-sasl-mechanism 'external) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :user "tester" + :full-name "tester") + (should (string= (buffer-name) (format "127.0.0.1:%d" port))))) + + (ert-info ("Notices received") + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "ExampleOrg")) + (funcall expect 10 "Authentication successful") + (funcall expect 10 "This server is in debug mode"))))) + +(ert-deftest erc-scenarios-sasl--plain-fail () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "sasl") + (erc-server-flood-penalty 0.1) + (dumb-server (erc-d-run "localhost" t 'plain-failed)) + (port (process-contact dumb-server :service)) + (erc-modules (cons 'sasl erc-modules)) + (erc-sasl-password "wrong") + (erc-sasl-mechanism 'plain) + (expect (erc-d-t-make-expecter)) + (buf nil)) + + (ert-info ("Connect") + (setq buf (erc :server "127.0.0.1" + :port port + :nick "tester" + :user "tester" + :full-name "tester")) + (let ((err (should-error + (with-current-buffer buf + (funcall expect 20 "Connection failed!"))))) + (should (string-search "please review" (cadr err))) + (with-current-buffer buf + (funcall expect 10 "Opening connection") + (funcall expect 20 "SASL authentication failed") + (should-not (erc-server-process-alive))))))) + +(defun erc-scenarios--common--sasl (mech) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "sasl") + (erc-server-flood-penalty 0.1) + (dumb-server (erc-d-run "localhost" t mech)) + (port (process-contact dumb-server :service)) + (erc-modules (cons 'sasl erc-modules)) + (erc-sasl-user :nick) + (erc-sasl-mechanism mech) + (mock-rvs (list "c5RqLCZy0L4fGkKAZ0hujFBs" "")) + (sasl-unique-id-function (lambda () (pop mock-rvs))) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "jilles" + :password "sesame" + :full-name "jilles") + (should (string= (buffer-name) (format "127.0.0.1:%d" port))))) + + (ert-info ("Notices received") + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "jaguar")) + (funcall expect 10 "Found your hostname") + (funcall expect 20 "marked as being away"))))) + +(ert-deftest erc-scenarios-sasl--scram-sha-1 () + :tags '(:expensive-test) + (let ((erc-sasl-authzid "jilles")) + (erc-scenarios--common--sasl 'scram-sha-1))) + +(ert-deftest erc-scenarios-sasl--scram-sha-256 () + :tags '(:expensive-test) + (unless (featurep 'sasl-scram-sha256) + (ert-skip "Emacs lacks sasl-scram-sha256")) + (erc-scenarios--common--sasl 'scram-sha-256)) + +;;; erc-scenarios-sasl.el ends here diff --git a/test/lisp/erc/resources/sasl/external.eld b/test/lisp/erc/resources/sasl/external.eld new file mode 100644 index 0000000000..2cd237ec4d --- /dev/null +++ b/test/lisp/erc/resources/sasl/external.eld @@ -0,0 +1,33 @@ +;; -*- mode: lisp-data; -*- +((cap-req 10 "CAP REQ :sasl")) +((nick 1 "NICK tester")) +((user 1 "USER tester 0 * :tester")) + +((auth-req 3.2 "AUTHENTICATE EXTERNAL") + (0.0 ":irc.example.org CAP * ACK :sasl") + (0.0 "AUTHENTICATE +")) + +((auth-noop 3.2 "AUTHENTICATE +") + (0.0 ":irc.example.org 900 * * tester :You are now logged in as tester") + (0.0 ":irc.example.org 903 * :Authentication successful")) + +((cap-end 3.2 "CAP END") + (0.0 ":irc.example.org 001 tester :Welcome to the ExampleOrg IRC Network tester") + (0.01 ":irc.example.org 002 tester :Your host is irc.example.org, running version oragono-2.6.1") + (0.01 ":irc.example.org 003 tester :This server was created Sat, 17 Jul 2021 09:06:42 UTC") + (0.01 ":irc.example.org 004 tester irc.example.org oragono-2.6.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0.0 ":irc.example.org 005 tester AWAYLEN=200 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX KICKLEN=390 :are supported by this server") + (0.01 ":irc.example.org 005 tester MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:1,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8MAPPING=rfc8265 UTF8ONLY :are supported by this server") + (0.01 ":irc.example.org 005 tester draft/CHATHISTORY=100 :are supported by this server") + (0.0 ":irc.example.org 251 tester :There are 1 users and 0 invisible on 1 server(s)") + (0.0 ":irc.example.org 252 tester 0 :IRC Operators online") + (0.0 ":irc.example.org 253 tester 0 :unregistered connections") + (0.0 ":irc.example.org 254 tester 0 :channels formed") + (0.0 ":irc.example.org 255 tester :I have 1 clients and 0 servers") + (0.0 ":irc.example.org 265 tester 1 1 :Current local users 1, max 1") + (0.21 ":irc.example.org 266 tester 1 1 :Current global users 1, max 1") + (0.0 ":irc.example.org 422 tester :MOTD File is missing")) + +((mode-user 1.2 "MODE tester +i") + (0.0 ":irc.example.org 221 tester +Zi") + (0.0 ":irc.example.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.")) diff --git a/test/lisp/erc/resources/sasl/plain-failed.eld b/test/lisp/erc/resources/sasl/plain-failed.eld new file mode 100644 index 0000000000..336700290c --- /dev/null +++ b/test/lisp/erc/resources/sasl/plain-failed.eld @@ -0,0 +1,16 @@ +;; -*- mode: lisp-data; -*- +((cap-req 10 "CAP REQ :sasl")) +((nick 1 "NICK tester")) +((user 1 "USER tester 0 * :tester") + (0.0 ":irc.foonet.org NOTICE * :*** Looking up your hostname...") + (0.0 ":irc.foonet.org NOTICE * :*** Found your hostname") + (0.0 ":irc.foonet.org CAP * ACK :cap-notify sasl")) + +((authenticate-plain 3.2 "AUTHENTICATE PLAIN") + (0.0 ":irc.foonet.org AUTHENTICATE +")) + +((authenticate-gimme 3.2 "AUTHENTICATE AHRlc3RlcgB3cm9uZw==") + (0.0 ":irc.foonet.org 900 * * tester :You are now logged in as tester") + (0.0 ":irc.foonet.org 904 * :SASL authentication failed: Invalid account credentials")) + +((cap-end 3.2 "CAP END")) diff --git a/test/lisp/erc/resources/sasl/plain.eld b/test/lisp/erc/resources/sasl/plain.eld new file mode 100644 index 0000000000..1341cd78e5 --- /dev/null +++ b/test/lisp/erc/resources/sasl/plain.eld @@ -0,0 +1,39 @@ +;; -*- mode: lisp-data; -*- +((cap-req 10 "CAP REQ :sasl")) +((nick 1 "NICK tester")) +((user 1 "USER tester 0 * :tester") + (0.0 ":irc.example.org NOTICE * :*** Looking up your hostname...") + (0.0 ":irc.example.org NOTICE * :*** Found your hostname") + (0.0 ":irc.example.org CAP * ACK :sasl")) + +((authenticate-plain 3.2 "AUTHENTICATE PLAIN") + (0.0 ":irc.example.org AUTHENTICATE +")) + +((authenticate-gimme 3.2 "AUTHENTICATE AHRlc3RlcgBwYXNzd29yZDEyMw==") + (0.0 ":irc.example.org 900 * * tester :You are now logged in as tester") + (0.0 ":irc.example.org 903 * :Authentication successful")) + +((cap-end 3.2 "CAP END") + (0.0 ":irc.example.org 001 tester :Welcome to the ExampleOrg IRC Network tester") + (0.01 ":irc.example.org 002 tester :Your host is irc.example.org, running version oragono-2.6.1") + (0.01 ":irc.example.org 003 tester :This server was created Sat, 17 Jul 2021 09:06:42 UTC") + (0.01 ":irc.example.org 004 tester irc.example.org oragono-2.6.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0.0 ":irc.example.org 005 tester AWAYLEN=200 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX KICKLEN=390 :are supported by this server") + (0.01 ":irc.example.org 005 tester MAXLIST=beI:60 MAXTARGETS=4 MODES MONITOR=100 NETWORK=ExampleOrg NICKLEN=32 PREFIX=(qaohv)~&@%+ STATUSMSG=~&@%+ TARGMAX=NAMES:1,LIST:1,KICK:1,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8MAPPING=rfc8265 UTF8ONLY :are supported by this server") + (0.01 ":irc.example.org 005 tester draft/CHATHISTORY=100 :are supported by this server") + (0.0 ":irc.example.org 251 tester :There are 1 users and 0 invisible on 1 server(s)") + (0.0 ":irc.example.org 252 tester 0 :IRC Operators online") + (0.0 ":irc.example.org 253 tester 0 :unregistered connections") + (0.0 ":irc.example.org 254 tester 0 :channels formed") + (0.0 ":irc.example.org 255 tester :I have 1 clients and 0 servers") + (0.0 ":irc.example.org 265 tester 1 1 :Current local users 1, max 1") + (0.21 ":irc.example.org 266 tester 1 1 :Current global users 1, max 1") + (0.0 ":irc.example.org 422 tester :MOTD File is missing")) + +((mode-user 1.2 "MODE tester +i") + (0.0 ":irc.example.org 221 tester +Zi") + (0.0 ":irc.example.org NOTICE tester :This server is in debug mode and is logging all user I/O. If you do not wish for everything you send to be readable by the server owner(s), please disconnect.")) + +((quit 5 "QUIT :\2ERC\2") + (0 ":tester!~u@yuvqisyu7m7qs.irc QUIT :Quit")) +((drop 1 DROP)) diff --git a/test/lisp/erc/resources/sasl/scram-sha-1.eld b/test/lisp/erc/resources/sasl/scram-sha-1.eld new file mode 100644 index 0000000000..49980e9e12 --- /dev/null +++ b/test/lisp/erc/resources/sasl/scram-sha-1.eld @@ -0,0 +1,47 @@ +;;; -*- mode: lisp-data -*- +((cap-req 5.2 "CAP REQ :sasl")) +((nick 10 "NICK jilles")) +((user 10 "USER user 0 * :jilles") + (0 "NOTICE AUTH :*** Processing connection to jaguar.test") + (0 "NOTICE AUTH :*** Looking up your hostname...") + (0 "NOTICE AUTH :*** Checking Ident") + (0 "NOTICE AUTH :*** No Ident response") + (0 "NOTICE AUTH :*** Found your hostname") + (0 ":jaguar.test CAP jilles ACK :sasl")) + +((auth-init 10 "AUTHENTICATE SCRAM-SHA-1") + (0 "AUTHENTICATE +")) + +((auth-challenge 10 "AUTHENTICATE bixhPWppbGxlcyxuPWppbGxlcyxyPWM1UnFMQ1p5MEw0ZkdrS0FaMGh1akZCcw==") + (0 "AUTHENTICATE cj1jNVJxTENaeTBMNGZHa0tBWjBodWpGQnNYUW9LY2l2cUN3OWlEWlBTcGIscz01bUpPNmQ0cmpDbnNCVTFYLGk9NDA5Ng==")) + +((auth-final 10 "AUTHENTICATE Yz1iaXhoUFdwcGJHeGxjeXc9LHI9YzVScUxDWnkwTDRmR2tLQVowaHVqRkJzWFFvS2NpdnFDdzlpRFpQU3BiLHA9T1ZVaGdQdTh3RW0yY0RvVkxmYUh6VlVZUFdVPQ==") + (0 "AUTHENTICATE dj1aV1IyM2M5TUppcjBaZ2ZHZjVqRXRMT242Tmc9")) + +((auth-done 10 "AUTHENTICATE +") + (0 ":jaguar.test 900 jilles jilles!jilles@localhost.stack.nl jilles :You are now logged in as jilles") + (0 ":jaguar.test 903 jilles :SASL authentication successful")) + +((cap-end 10.2 "CAP END") + (0 ":jaguar.test 001 jilles :Welcome to the jaguar IRC Network jilles!~jilles@127.0.0.1") + (0 ":jaguar.test 002 jilles :Your host is jaguar.test, running version InspIRCd-3") + (0 ":jaguar.test 003 jilles :This server was created 09:44:05 Dec 24 2020") + (0 ":jaguar.test 004 jilles jaguar.test InspIRCd-3 BILRSWcghiorswz ABEFHIJLMNOQRSTXYabcefghijklmnopqrstuvz :BEFHIJLXYabefghjkloqv") + (0 ":jaguar.test 005 jilles ACCEPT=30 AWAYLEN=200 BOT=B CALLERID=g CASEMAPPING=rfc1459 CHANLIMIT=#:120 CHANMODES=IXbeg,k,BEFHJLfjl,AMNOQRSTcimnprstuz CHANNELLEN=64 CHANTYPES=# ELIST=CMNTU ESILENCE=CcdiNnPpTtx EXCEPTS=e :are supported by this server") + (0 ":jaguar.test 005 jilles EXTBAN=,ANOQRSTUacmnprz HOSTLEN=64 INVEX=I KEYLEN=32 KICKLEN=255 LINELEN=512 MAXLIST=I:100,X:100,b:100,e:100,g:100 MAXTARGETS=20 MODES=20 MONITOR=30 NAMELEN=128 NAMESX NETWORK=jaguar :are supported by this server") + (0 ":jaguar.test 005 jilles NICKLEN=31 PREFIX=(Yqaohv)!~&@%+ REMOVE SAFELIST SECURELIST=60 SILENCE=32 STATUSMSG=!~&@%+ TOPICLEN=307 UHNAMES USERIP USERLEN=11 USERMODES=,,s,BILRSWcghiorwz WATCH=30 :are supported by this server") + (0 ":jaguar.test 005 jilles :are supported by this server") + (0 ":jaguar.test 251 jilles :There are 740 users and 108 invisible on 11 servers") + (0 ":jaguar.test 252 jilles 10 :operator(s) online") + (0 ":jaguar.test 254 jilles 373 :channels formed") + (0 ":jaguar.test 255 jilles :I have 28 clients and 1 servers") + (0 ":jaguar.test 265 jilles :Current local users: 28 Max: 29") + (0 ":jaguar.test 266 jilles :Current global users: 848 Max: 879") + (0 ":jaguar.test 375 jilles :jaguar.test message of the day") + (0 ":jaguar.test 372 jilles : ~~ some message of the day ~~") + (0 ":jaguar.test 372 jilles : ~~ or rkpryyrag gb rnpu bgure ~~") + (0 ":jaguar.test 376 jilles :End of message of the day.")) + +((mode-user 1.2 "MODE jilles +i") + (0 ":jilles!~jilles@127.0.0.1 MODE jilles :+ri") + (0 ":jaguar.test 306 jilles :You have been marked as being away")) diff --git a/test/lisp/erc/resources/sasl/scram-sha-256.eld b/test/lisp/erc/resources/sasl/scram-sha-256.eld new file mode 100644 index 0000000000..74de9a23ec --- /dev/null +++ b/test/lisp/erc/resources/sasl/scram-sha-256.eld @@ -0,0 +1,47 @@ +;;; -*- mode: lisp-data -*- +((cap-req 5.2 "CAP REQ :sasl")) +((nick 10 "NICK jilles")) +((user 10 "USER user 0 * :jilles") + (0 "NOTICE AUTH :*** Processing connection to jaguar.test") + (0 "NOTICE AUTH :*** Looking up your hostname...") + (0 "NOTICE AUTH :*** Checking Ident") + (0 "NOTICE AUTH :*** No Ident response") + (0 "NOTICE AUTH :*** Found your hostname") + (0 ":jaguar.test CAP jilles ACK :sasl")) + +((auth-init 10 "AUTHENTICATE SCRAM-SHA-256") + (0 "AUTHENTICATE +")) + +((auth-challenge 10 "AUTHENTICATE biwsbj1qaWxsZXMscj1jNVJxTENaeTBMNGZHa0tBWjBodWpGQnM=") + (0 "AUTHENTICATE cj1jNVJxTENaeTBMNGZHa0tBWjBodWpGQnNkNDA2N2YwYWZkYjU0YzNkYmQ0ZmU2NDViODRjYWUzNyxzPVpUZzFNbUUxWW1GaFpHSTFORGN5TWprM056WXdabVJqWkRNM1kySTFPVE09LGk9NDA5Ng==")) + +((auth-final 10 "AUTHENTICATE Yz1iaXdzLHI9YzVScUxDWnkwTDRmR2tLQVowaHVqRkJzZDQwNjdmMGFmZGI1NGMzZGJkNGZlNjQ1Yjg0Y2FlMzcscD1MUDRzakpyakpLcDVxVHNBUnlaQ3BwWHBLTHU0Rk1NMjg0aE5FU1B2R2hJPQ==") + (0 "AUTHENTICATE dj04NDdXWGZubVJlR3lFMXFscTFBbmQ2UjRiUEJOUk9UWjdFTVMvUXJKdFVNPQ==")) + +((auth-done 10 "AUTHENTICATE +") + (0 ":jaguar.test 900 jilles jilles!jilles@localhost.stack.nl jilles :You are now logged in as jilles") + (0 ":jaguar.test 903 jilles :SASL authentication successful")) + +((cap-end 10.2 "CAP END") + (0 ":jaguar.test 001 jilles :Welcome to the jaguar IRC Network jilles!~jilles@127.0.0.1") + (0 ":jaguar.test 002 jilles :Your host is jaguar.test, running version InspIRCd-3") + (0 ":jaguar.test 003 jilles :This server was created 09:44:05 Dec 24 2020") + (0 ":jaguar.test 004 jilles jaguar.test InspIRCd-3 BILRSWcghiorswz ABEFHIJLMNOQRSTXYabcefghijklmnopqrstuvz :BEFHIJLXYabefghjkloqv") + (0 ":jaguar.test 005 jilles ACCEPT=30 AWAYLEN=200 BOT=B CALLERID=g CASEMAPPING=rfc1459 CHANLIMIT=#:120 CHANMODES=IXbeg,k,BEFHJLfjl,AMNOQRSTcimnprstuz CHANNELLEN=64 CHANTYPES=# ELIST=CMNTU ESILENCE=CcdiNnPpTtx EXCEPTS=e :are supported by this server") + (0 ":jaguar.test 005 jilles EXTBAN=,ANOQRSTUacmnprz HOSTLEN=64 INVEX=I KEYLEN=32 KICKLEN=255 LINELEN=512 MAXLIST=I:100,X:100,b:100,e:100,g:100 MAXTARGETS=20 MODES=20 MONITOR=30 NAMELEN=128 NAMESX NETWORK=jaguar :are supported by this server") + (0 ":jaguar.test 005 jilles NICKLEN=31 PREFIX=(Yqaohv)!~&@%+ REMOVE SAFELIST SECURELIST=60 SILENCE=32 STATUSMSG=!~&@%+ TOPICLEN=307 UHNAMES USERIP USERLEN=11 USERMODES=,,s,BILRSWcghiorwz WATCH=30 :are supported by this server") + (0 ":jaguar.test 005 jilles :are supported by this server") + (0 ":jaguar.test 251 jilles :There are 740 users and 108 invisible on 11 servers") + (0 ":jaguar.test 252 jilles 10 :operator(s) online") + (0 ":jaguar.test 254 jilles 373 :channels formed") + (0 ":jaguar.test 255 jilles :I have 28 clients and 1 servers") + (0 ":jaguar.test 265 jilles :Current local users: 28 Max: 29") + (0 ":jaguar.test 266 jilles :Current global users: 848 Max: 879") + (0 ":jaguar.test 375 jilles :jaguar.test message of the day") + (0 ":jaguar.test 372 jilles : ~~ some message of the day ~~") + (0 ":jaguar.test 372 jilles : ~~ or rkpryyrag gb rnpu bgure ~~") + (0 ":jaguar.test 376 jilles :End of message of the day.")) + +((mode-user 1.2 "MODE jilles +i") + (0 ":jilles!~jilles@127.0.0.1 MODE jilles :+ri") + (0 ":jaguar.test 306 jilles :You have been marked as being away")) commit ae254a65cd6c0292865c449d639140f5d149f68e Author: F. Jason Park Date: Sun Sep 18 01:49:23 2022 -0700 Call erc-login indirectly via new generic wrapper * lisp/erc/erc-backend (erc--register-connection): Add new internal generic function that defers to `erc-login' by default. (erc-process-sentinel, erc-server-connect): Call `erc--register-connection' instead of `erc-login'. diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 30b53dfd8e..973616bc37 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -643,6 +643,10 @@ erc-open-network-stream (let ((p (plist-put parameters :nowait t))) (apply #'open-network-stream name buffer host service p))) +(cl-defmethod erc--register-connection () + "Perform opening IRC protocol exchange with server." + (erc-login)) + (defvar erc--server-connect-dumb-ipv6-regexp ;; Not for validation (gives false positives). (rx bot "[" (group (+ (any xdigit digit ":.")) (? "%" (+ alnum))) "]" eot)) @@ -697,7 +701,7 @@ erc-server-connect ;; waiting for a non-blocking connect - keep the user informed (erc-display-message nil nil buffer "Opening connection..\n") (message "%s...done" msg) - (erc-login)) )) + (erc--register-connection)))) (defun erc-server-reconnect () "Reestablish the current IRC connection. @@ -897,7 +901,7 @@ erc-process-sentinel cproc (process-status cproc) event erc-server-quitting)) (if (string-match "^open" event) ;; newly opened connection (no wait) - (erc-login) + (erc--register-connection) ;; assume event is 'failed (erc-with-all-buffers-of-server cproc nil (setq erc-server-connected nil)) commit 4c4936fab2ecd97ff6e03e5cfe12def4626c718b Author: F. Jason Park Date: Mon Jul 12 03:44:28 2021 -0700 Support local ERC modules in erc-mode buffers * doc/misc/erc.texi: Mention local modules in Modules chapter. * etc/ERC-NEWS: Mention changes to `erc-update-modules'. * lisp/erc/erc.el (erc-migrate-modules): Add some missing mappings. (erc-modules): When a user removes a module, disable it and kill its local variable in all ERC buffers. (erc-update-modules): Move body of `erc-update-modules' to new internal function. (erc--update-modules): Add new function, a renamed and slightly modified version of `erc-update-modules'. Specifically, change return value from nil to a list of minor-mode commands for local modules. Use `custom-variable-p' to detect flavor. (erc--merge-local-modes): Add helper for finding local modules already active as minor modes in an ERC buffer. (erc-open): Replace `erc-update-modules' with `erc--update-modules'. Defer enabling of local modules via `erc--update-modules' until after buffer is initialized with other local vars. Also defer major-mode hooks so they can detect things like whether the buffer is a server or target buffer. Also ensure local module setup code can detect when `erc-open' was called with a non-nil `erc--server-reconnecting'. * lisp/erc/erc-common.el (erc--module-name-migrations, erc--features-to-modules, erc--modules-to-features): Add alists of old-to-new module names to support module-name migrations. (erc--assemble-toggle): Add new helper for constructing mode toggles, like `erc-sasl-enable'. (define-erc-modules): Defer to `erc--assemble-toggle' to create toggle commands. (erc--normalize-module-symbol): Add helper for `erc-migrate-modules'. * lisp/erc/erc-goodies.el: Require cl-lib. * test/lisp/erc/erc-tests.el (erc-migrate-modules, erc--update-modules): Add rudimentary unit tests asserting correct module-name mappings. (erc--merge-local-modes): Add test for helper. (define-erc-module--global, define-erc-module--local): Add tests asserting module-creation macro. (Bug#57955.) diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi index 0d807e323e..b9c6e33d36 100644 --- a/doc/misc/erc.texi +++ b/doc/misc/erc.texi @@ -390,8 +390,11 @@ Modules There is a spiffy customize interface, which may be reached by typing @kbd{M-x customize-option @key{RET} erc-modules @key{RET}}. -Alternatively, set @code{erc-modules} manually and then call -@code{erc-update-modules}. +When removing a module outside of the Custom ecosystem, you may wish +to ensure it's disabled by invoking its associated minor-mode toggle, +such as @kbd{M-x erc-spelling-mode @key{RET}}. Note that, these days, +calling @code{erc-update-modules} in an init file is typically +unnecessary. The following is a list of available modules. @@ -517,6 +520,38 @@ Modules @end table +@subheading Local Modules +@cindex local modules + +All modules operate as minor modes under the hood, and some newer ones +may be defined as buffer-local. These so-called ``local modules'' are +a work in progress and their behavior and interface are subject to +change. As of ERC 5.5, the only practical differences are + +@enumerate +@item +``Control variables,'' like @code{erc-sasl-mode}, are stateful across +IRC sessions and override @code{erc-module} membership when influencing +module activation in new sessions. +@item +Removing a local module from @code{erc-modules} via Customize not only +disables its mode but also kills its control variable in all ERC +buffers. +@item +``Mode toggles,'' like @code{erc-sasl-mode} and +@code{erc-sasl-enable}, behave differently relative to each other and +to their global counterparts. (More on this just below.) +@end enumerate + +By default, all local-mode toggles, like @code{erc-sasl-mode}, only +affect the current buffer, but their ``non-mode'' variants, such as +@code{erc-sasl-enable}, operate on all buffers belonging to a +connection when called interactively. Keep in mind that whether +enabled or not, a module may effectively be ``inert'' in certain types +of buffers, such as queries and channels. Whatever the case, a local +toggle never mutates @code{erc-modules}. + + @c PRE5_4: Document every option of every module in its own subnode diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index f638d4717a..15f7fe84dd 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -125,6 +125,15 @@ The function 'erc-auto-query' was deemed too difficult to reason through and has thus been deprecated with no public replacement; it has also been removed from the client code path. +The function 'erc-open' now delays running 'erc-mode-hook' members +until most local session variables have been initialized (minus those +connection-related ones in erc-backend). 'erc-open' also no longer +calls 'erc-update-modules', although modules are still activated +in an identical fashion. + +Some groundwork has been laid for what may become a new breed of ERC +module, namely, "connection-local" (or simply "local") modules. + A few internal variables have been introduced that could just as well have been made public, possibly as user options. Likewise for some internal functions. As always, users needing such functionality diff --git a/lisp/erc/erc-common.el b/lisp/erc/erc-common.el index 23a1933798..a4046ba9b3 100644 --- a/lisp/erc/erc-common.el +++ b/lisp/erc/erc-common.el @@ -88,6 +88,65 @@ erc--target (contents "" :type string) (tags '() :type list)) +;; TODO move goodies modules here after 29 is released. +(defconst erc--features-to-modules + '((erc-pcomplete completion pcomplete) + (erc-capab capab-identify) + (erc-join autojoin) + (erc-page page ctcp-page) + (erc-sound sound ctcp-sound) + (erc-stamp stamp timestamp) + (erc-services services nickserv)) + "Migration alist mapping a library feature to module names. +Keys need not be unique: a library may define more than one +module. Sometimes a module's downcased alias will be its +canonical name.") + +(defconst erc--modules-to-features + (let (pairs) + (pcase-dolist (`(,feature . ,names) erc--features-to-modules) + (dolist (name names) + (push (cons name feature) pairs))) + (nreverse pairs)) + "Migration alist mapping a module's name to its home library feature.") + +(defconst erc--module-name-migrations + (let (pairs) + (pcase-dolist (`(,_ ,canonical . ,rest) erc--features-to-modules) + (dolist (obsolete rest) + (push (cons obsolete canonical) pairs))) + pairs) + "Association list of obsolete module names to canonical names.") + +(defun erc--normalize-module-symbol (symbol) + "Return preferred SYMBOL for `erc-modules'." + (setq symbol (intern (downcase (symbol-name symbol)))) + (or (cdr (assq symbol erc--module-name-migrations)) symbol)) + +(defun erc--assemble-toggle (localp name ablsym mode val body) + (let ((arg (make-symbol "arg"))) + `(defun ,ablsym ,(if localp `(&optional ,arg) '()) + ,(concat + (if val "Enable" "Disable") + " ERC " (symbol-name name) " mode." + (when localp + "\nWith ARG, do so in all buffers for the current connection.")) + (interactive ,@(when localp '("p"))) + ,@(if localp + `((when (derived-mode-p 'erc-mode) + (if ,arg + (erc-with-all-buffers-of-server erc-server-process nil + (,ablsym)) + (setq ,mode ,val) + ,@body))) + `(,(if val + `(cl-pushnew ',(erc--normalize-module-symbol name) + erc-modules) + `(setq erc-modules (delq ',(erc--normalize-module-symbol name) + erc-modules))) + (setq ,mode ,val) + ,@body))))) + (defmacro define-erc-module (name alias doc enable-body disable-body &optional local-p) "Define a new minor mode using ERC conventions. @@ -103,6 +162,13 @@ define-erc-module an alias erc-ALIAS-mode, as well as the helper functions erc-NAME-enable, and erc-NAME-disable. +With LOCAL-P, these helpers take on an optional argument that, +when non-nil, causes them to act on all buffers of a connection. +This feature is mainly intended for interactive use and does not +carry over to their respective minor-mode toggles. Beware that +for global modules, these helpers and toggles all mutate +`erc-modules'. + Example: ;;;###autoload(autoload \\='erc-replace-mode \"erc-replace\") @@ -133,20 +199,8 @@ define-erc-module (if ,mode (,enable) (,disable))) - (defun ,enable () - ,(format "Enable ERC %S mode." - name) - (interactive) - (add-to-list 'erc-modules (quote ,name)) - (setq ,mode t) - ,@enable-body) - (defun ,disable () - ,(format "Disable ERC %S mode." - name) - (interactive) - (setq erc-modules (delq (quote ,name) erc-modules)) - (setq ,mode nil) - ,@disable-body) + ,(erc--assemble-toggle local-p name enable mode t enable-body) + ,(erc--assemble-toggle local-p name disable mode nil disable-body) ,(when (and alias (not (eq name alias))) `(defalias ',(intern diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el index 59b5f01f23..1af83b58ba 100644 --- a/lisp/erc/erc-goodies.el +++ b/lisp/erc/erc-goodies.el @@ -31,6 +31,7 @@ ;;; Imenu support +(eval-when-compile (require 'cl-lib)) (require 'erc-common) (defvar erc-controls-highlight-regexp) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 352f72e617..384d92e624 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -1791,10 +1791,7 @@ erc-migrate-modules "Migrate old names of ERC modules to new ones." ;; modify `transforms' to specify what needs to be changed ;; each item is in the format '(old . new) - (let ((transforms '((pcomplete . completion)))) - (delete-dups - (mapcar (lambda (m) (or (cdr (assoc m transforms)) m)) - mods)))) + (delete-dups (mapcar #'erc--normalize-module-symbol mods))) (defcustom erc-modules '(netsplit fill button match track completion readonly networks ring autojoin noncommands irccontrols @@ -1813,9 +1810,16 @@ erc-modules (dolist (module erc-modules) (unless (member module val) (let ((f (intern-soft (format "erc-%s-mode" module)))) - (when (and (fboundp f) (boundp f) (symbol-value f)) - (message "Disabling `erc-%s'" module) - (funcall f 0)))))) + (when (and (fboundp f) (boundp f)) + (when (symbol-value f) + (message "Disabling `erc-%s'" module) + (funcall f 0)) + (unless (or (custom-variable-p f) + (not (fboundp 'erc-buffer-filter))) + (erc-buffer-filter (lambda () + (when (symbol-value f) + (funcall f 0)) + (kill-local-variable f))))))))) (set sym val) ;; this test is for the case where erc hasn't been loaded yet (when (fboundp 'erc-update-modules) @@ -1873,27 +1877,23 @@ erc-modules :group 'erc) (defun erc-update-modules () - "Run this to enable erc-foo-mode for all modules in `erc-modules'." - (let (req) - (dolist (mod erc-modules) - (setq req (concat "erc-" (symbol-name mod))) - (cond - ;; yuck. perhaps we should bring the filenames into sync? - ((string= req "erc-capab-identify") - (setq req "erc-capab")) - ((string= req "erc-completion") - (setq req "erc-pcomplete")) - ((string= req "erc-pcomplete") - (setq mod 'completion)) - ((string= req "erc-autojoin") - (setq req "erc-join"))) - (condition-case nil - (require (intern req)) - (error nil)) - (let ((sym (intern-soft (concat "erc-" (symbol-name mod) "-mode")))) - (if (fboundp sym) - (funcall sym 1) - (error "`%s' is not a known ERC module" mod)))))) + "Enable minor mode for every module in `erc-modules'. +Except ignore all local modules, which were introduced in ERC 5.5." + (erc--update-modules) + nil) + +(defun erc--update-modules () + (let (local-modes) + (dolist (module erc-modules local-modes) + (require (or (alist-get module erc--modules-to-features) + (intern (concat "erc-" (symbol-name module)))) + nil 'noerror) ; some modules don't have a corresponding feature + (let ((mode (intern-soft (concat "erc-" (symbol-name module) "-mode")))) + (unless (and mode (fboundp mode)) + (error "`%s' is not a known ERC module" module)) + (if (custom-variable-p mode) + (funcall mode 1) + (push mode local-modes)))))) (defun erc-setup-buffer (buffer) "Consults `erc-join-buffer' to find out how to display `BUFFER'." @@ -1924,6 +1924,24 @@ erc-setup-buffer (display-buffer buffer) (switch-to-buffer buffer))))) +(defun erc--merge-local-modes (new-modes old-vars) + "Return a cons of two lists, each containing local-module modes. +In the first, put modes to be enabled in a new ERC buffer by +calling their associated functions. In the second, put modes to +be marked as disabled by setting their associated variables to +nil." + (if old-vars + (let ((out (list (reverse new-modes)))) + (pcase-dolist (`(,k . ,v) old-vars) + (when (and (string-prefix-p "erc-" (symbol-name k)) + (string-suffix-p "-mode" (symbol-name k))) + (if v + (cl-pushnew k (car out)) + (setf (car out) (delq k (car out))) + (cl-pushnew k (cdr out))))) + (cons (nreverse (car out)) (nreverse (cdr out)))) + (list new-modes))) + (defun erc-open (&optional server port nick full-name connect passwd tgt-list channel process client-certificate user id) @@ -1951,18 +1969,25 @@ erc-open (let* ((target (and channel (erc--target-from-string channel))) (buffer (erc-get-buffer-create server port nil target id)) (old-buffer (current-buffer)) - old-point + (old-vars (and (not connect) (buffer-local-variables))) + (old-recon-count erc-server-reconnect-count) + (old-point nil) + (delayed-modules nil) (continued-session (and erc--server-reconnecting (with-suppressed-warnings ((obsolete erc-reuse-buffers)) erc-reuse-buffers)))) (when connect (run-hook-with-args 'erc-before-connect server port nick)) - (erc-update-modules) (set-buffer buffer) (setq old-point (point)) - (let ((old-recon-count erc-server-reconnect-count)) - (erc-mode) - (setq erc-server-reconnect-count old-recon-count)) + (setq delayed-modules + (erc--merge-local-modes (erc--update-modules) + (or erc--server-reconnecting old-vars))) + + (delay-mode-hooks (erc-mode)) + + (setq erc-server-reconnect-count old-recon-count) + (when (setq erc-server-connected (not connect)) (setq erc-server-announced-name (buffer-local-value 'erc-server-announced-name old-buffer))) @@ -2019,14 +2044,21 @@ erc-open (setq erc-session-client-certificate client-certificate) (setq erc-networks--id (if connect - (or (and continued-session - (buffer-local-value 'erc-networks--id old-buffer)) + (or (and erc--server-reconnecting + (alist-get 'erc-networks--id erc--server-reconnecting)) (and id (erc-networks--id-create id))) (buffer-local-value 'erc-networks--id old-buffer))) ;; debug output buffer (setq erc-dbuf (when erc-log-p (get-buffer-create (concat "*ERC-DEBUG: " server "*")))) + + (erc-determine-parameters server port nick full-name user passwd) + + (save-excursion (run-mode-hooks)) + (dolist (mod (car delayed-modules)) (funcall mod +1)) + (dolist (var (cdr delayed-modules)) (set var nil)) + ;; set up prompt (unless continued-session (goto-char (point-max)) @@ -2038,8 +2070,6 @@ erc-open (erc-display-prompt) (goto-char (point-max))) - (erc-determine-parameters server port nick full-name user passwd) - ;; Saving log file on exit (run-hook-with-args 'erc-connect-pre-hook buffer) diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index ff5d802697..b185d850a6 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -1178,4 +1178,160 @@ erc-handle-irc-url (kill-buffer "baznet") (kill-buffer "#chan"))) +(ert-deftest erc-migrate-modules () + (should (equal (erc-migrate-modules '(autojoin timestamp button)) + '(autojoin stamp button))) + ;; Default unchanged + (should (equal (erc-migrate-modules erc-modules) erc-modules))) + +(ert-deftest erc--update-modules () + (let (calls + erc-modules + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + (cl-letf (((symbol-function 'require) + (lambda (s &rest _) (push s calls))) + + ;; Local modules + ((symbol-function 'erc-fake-bar-mode) + (lambda (n) (push (cons 'fake-bar n) calls))) + + ;; Global modules + ((symbol-function 'erc-fake-foo-mode) + (lambda (n) (push (cons 'fake-foo n) calls))) + ((get 'erc-fake-foo-mode 'standard-value) 'ignore) + ((symbol-function 'erc-autojoin-mode) + (lambda (n) (push (cons 'autojoin n) calls))) + ((get 'erc-autojoin-mode 'standard-value) 'ignore) + ((symbol-function 'erc-networks-mode) + (lambda (n) (push (cons 'networks n) calls))) + ((get 'erc-networks-mode 'standard-value) 'ignore) + ((symbol-function 'erc-completion-mode) + (lambda (n) (push (cons 'completion n) calls))) + ((get 'erc-completion-mode 'standard-value) 'ignore)) + + (ert-info ("Local modules") + (setq erc-modules '(fake-foo fake-bar)) + (should (equal (erc--update-modules) '(erc-fake-bar-mode))) + ;; Bar the feature is still required but the mode is not activated + (should (equal (nreverse calls) + '(erc-fake-foo (fake-foo . 1) erc-fake-bar))) + (setq calls nil)) + + (ert-info ("Module name overrides") + (setq erc-modules '(completion autojoin networks)) + (should-not (erc--update-modules)) ; no locals + (should (equal (nreverse calls) '( erc-pcomplete (completion . 1) + erc-join (autojoin . 1) + erc-networks (networks . 1)))) + (setq calls nil))))) + +(ert-deftest erc--merge-local-modes () + + (ert-info ("No existing modes") + (let ((old '((a) (b . t))) + (new '(erc-c-mode erc-d-mode))) + (should (equal (erc--merge-local-modes new old) + '((erc-c-mode erc-d-mode)))))) + + (ert-info ("Active existing added, inactive existing removed, deduped") + (let ((old '((a) (erc-b-mode) (c . t) (erc-d-mode . t) (erc-e-mode . t))) + (new '(erc-b-mode erc-d-mode))) + (should (equal (erc--merge-local-modes new old) + '((erc-d-mode erc-e-mode) . (erc-b-mode))))))) + +(ert-deftest define-erc-module--global () + (let ((global-module '(define-erc-module mname malias + "Some docstring" + ((ignore a) (ignore b)) + ((ignore c) (ignore d))))) + + (should (equal (macroexpand global-module) + `(progn + + (define-minor-mode erc-mname-mode + "Toggle ERC mname mode. +With a prefix argument ARG, enable mname if ARG is positive, +and disable it otherwise. If called from Lisp, enable the mode +if ARG is omitted or nil. +Some docstring" + :global t + :group 'erc-mname + (if erc-mname-mode + (erc-mname-enable) + (erc-mname-disable))) + + (defun erc-mname-enable () + "Enable ERC mname mode." + (interactive) + (cl-pushnew 'mname erc-modules) + (setq erc-mname-mode t) + (ignore a) (ignore b)) + + (defun erc-mname-disable () + "Disable ERC mname mode." + (interactive) + (setq erc-modules (delq 'mname erc-modules)) + (setq erc-mname-mode nil) + (ignore c) (ignore d)) + + (defalias 'erc-malias-mode #'erc-mname-mode) + + (put 'erc-mname-mode 'definition-name 'mname) + (put 'erc-mname-enable 'definition-name 'mname) + (put 'erc-mname-disable 'definition-name 'mname)))))) + +(ert-deftest define-erc-module--local () + (let* ((global-module '(define-erc-module mname malias + "Some docstring" + ((ignore a) (ignore b)) + ((ignore c) (ignore d)) + 'local)) + (got (macroexpand global-module)) + (arg-en (cadr (nth 2 (nth 2 got)))) + (arg-dis (cadr (nth 2 (nth 3 got))))) + + (should (equal got + `(progn + (define-minor-mode erc-mname-mode + "Toggle ERC mname mode. +With a prefix argument ARG, enable mname if ARG is positive, +and disable it otherwise. If called from Lisp, enable the mode +if ARG is omitted or nil. +Some docstring" + :global nil + :group 'erc-mname + (if erc-mname-mode + (erc-mname-enable) + (erc-mname-disable))) + + (defun erc-mname-enable (&optional ,arg-en) + "Enable ERC mname mode. +With ARG, do so in all buffers for the current connection." + (interactive "p") + (when (derived-mode-p 'erc-mode) + (if ,arg-en + (erc-with-all-buffers-of-server + erc-server-process nil + (erc-mname-enable)) + (setq erc-mname-mode t) + (ignore a) (ignore b)))) + + (defun erc-mname-disable (&optional ,arg-dis) + "Disable ERC mname mode. +With ARG, do so in all buffers for the current connection." + (interactive "p") + (when (derived-mode-p 'erc-mode) + (if ,arg-dis + (erc-with-all-buffers-of-server + erc-server-process nil + (erc-mname-disable)) + (setq erc-mname-mode nil) + (ignore c) (ignore d)))) + + (defalias 'erc-malias-mode #'erc-mname-mode) + + (put 'erc-mname-mode 'definition-name 'mname) + (put 'erc-mname-enable 'definition-name 'mname) + (put 'erc-mname-disable 'definition-name 'mname)))))) + ;;; erc-tests.el ends here commit dc6ff142bc1c1a8596436e08ddbccb39d8fdcf39 Author: F. Jason Park Date: Fri Nov 18 22:42:15 2022 -0800 Make erc--server-reconnecting non-buffer-local * lisp/erc/erc-backend.el (erc--server-reconnecting): Mention expected non-nil value type in doc string. (erc-server-connect): Don't set `erc--server-reconnecting'. (erc-server--reconnect): Let-bind `erc--server-reconnecting' instead of setting it locally in the server buffer. Set it to an alist containing the current buffer's local variables. (erc-process-sentinel-2): Don't set `erc--server-reconnect'. * lisp/erc/erc.el (erc--cmd-reconnect): Clean up some assertions. (Bug#57955.) diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index f899b866f0..30b53dfd8e 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -311,8 +311,13 @@ erc-server-reconnecting (make-obsolete-variable 'erc-server-reconnecting "see `erc--server-reconnecting'" "29.1") -(defvar-local erc--server-reconnecting nil - "Non-nil when reconnecting.") +(defvar erc--server-reconnecting nil + "An alist of buffer-local vars and their values when reconnecting. +This is for the benefit of local modules and `erc-mode-hook' +members so they can access buffer-local data from the previous +session when reconnecting. Once `erc-reuse-buffers' is retired +and fully removed, modules can switch to leveraging the +`permanent-local' property instead.") (defvar-local erc-server-timed-out nil "Non-nil if the IRC server failed to respond to a ping.") @@ -664,7 +669,6 @@ erc-server-connect (setq erc-server-process process) (setq erc-server-quitting nil) (setq erc-server-reconnecting nil - erc--server-reconnecting nil erc--server-reconnect-timer nil) (setq erc-server-timed-out nil) (setq erc-server-banned nil) @@ -706,11 +710,11 @@ erc-server-reconnect (with-current-buffer buffer (erc-update-mode-line) (erc-set-active-buffer (current-buffer)) - (setq erc--server-reconnecting t) (setq erc-server-last-sent-time 0) (setq erc-server-lines-sent 0) (let ((erc-server-connect-function (or erc-session-connector - #'erc-open-network-stream))) + #'erc-open-network-stream)) + (erc--server-reconnecting (buffer-local-variables))) (erc-open erc-session-server erc-session-port erc-server-current-nick erc-session-user-full-name t erc-session-password nil nil nil erc-session-client-certificate @@ -824,8 +828,7 @@ erc-process-sentinel-2 (if (not reconnect-p) ;; terminate, do not reconnect (progn - (setq erc--server-reconnecting nil - erc--server-reconnect-timer nil) + (setq erc--server-reconnect-timer nil) (erc-display-message nil 'error (current-buffer) 'terminated ?e event) (set-buffer-modified-p nil)) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 1052c8c4c0..352f72e617 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -3834,10 +3834,8 @@ erc--cmd-reconnect (with-suppressed-warnings ((obsolete erc-server-reconnecting) (obsolete erc-reuse-buffers)) (if erc-reuse-buffers - (progn (cl-assert (not erc--server-reconnecting)) - (cl-assert (not erc-server-reconnecting))) - (setq erc--server-reconnecting nil - erc-server-reconnecting nil))))) + (cl-assert (not erc-server-reconnecting)) + (setq erc-server-reconnecting nil))))) t) (defun erc-cmd-RECONNECT (&rest args) commit da30a4908ec1482c6d86150a197655fb99f8d68a Author: F. Jason Park Date: Sun Nov 13 01:52:48 2022 -0800 Don't set erc-networks--id until network is known * lisp/erc/erc-networks.el (erc-networks--id-given): Accept a null argument. (erc-networks--id-on-connect): Remove unused function. (erc-networks--id-equal-p): Add method for comparing initialized and unset IDs. (erc-networks--update-server-identity): Ensure `erc-networks--id' is set before continuing search. (erc-networks--init-identity): Don't assume `erc-networks--id' is non-nil. Add branch condition to reload ID on non-nil case. (erc-networks-on-MOTD-end): Let init-ID function handle renaming of server buffer. * lisp/erc/erc.el (erc-open): For continued sessions, try copying over the last network ID. (erc--auth-source-determine-params-default): Don't expect a network ID to have been initialized. (erc-set-current-nick): When connected, reload network ID. Leave comment warning that it may be unneeded. * lisp/erc/erc-backend.el (erc-server-NICK, erc-server-433): Unless already connected, schedule ID reload when server rejects or mandates a nick change. * test/lisp/erc/erc-scenarios-base-association-nick.el (erc-scenarios-base-association-nick-bumped, erc-scenarios-base-association-nick-bumped-mandated-renick): Update to reflect more liberal association behavior when renamed by IRCd. diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 15fd6ac50f..f899b866f0 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -1619,7 +1619,7 @@ define-erc-response-handler (cl-pushnew (erc-server-buffer) bufs) (erc-set-current-nick nn) ;; Rename session, possibly rename server buf and all targets - (when (erc-network) + (when erc-server-connected (erc-networks--id-reload erc-networks--id proc parsed)) (erc-update-mode-line) (setq erc-nick-change-attempt-count 0) @@ -1629,6 +1629,8 @@ define-erc-response-handler 'NICK-you ?n nick ?N nn) (run-hook-with-args 'erc-nick-changed-functions nn nick)) (t + (when erc-server-connected + (erc-networks--id-reload erc-networks--id proc parsed)) (erc-handle-user-status-change 'nick (list nick login host) (list nn)) (erc-display-message parsed 'notice bufs 'NICK ?n nick ?u login ?h host ?N nn)))))) @@ -2255,6 +2257,8 @@ erc-server-322-message (define-erc-response-handler (433) "Login-time \"nick in use\"." nil + (when erc-server-connected + (erc-networks--id-reload erc-networks--id proc parsed)) (erc-nickname-in-use (cadr (erc-response.command-args parsed)) "already in use")) diff --git a/lisp/erc/erc-networks.el b/lisp/erc/erc-networks.el index b3e5fcf1a3..19a7ab8643 100644 --- a/lisp/erc/erc-networks.el +++ b/lisp/erc/erc-networks.el @@ -826,12 +826,11 @@ erc-networks--id ;; For now, please use this instead of `erc-networks--id-fixed-p'. (cl-defgeneric erc-networks--id-given (net-id) - "Return the preassigned identifier for a network presence, if any. -This may have originated from an `:id' arg to entry-point commands -`erc-tls' or `erc'.") + "Return the preassigned identifier for a network context, if any. +When non-nil, assume NET-ID originated from an `:id' argument to +entry-point commands `erc-tls' or `erc'.") -(cl-defmethod erc-networks--id-given ((_ erc-networks--id)) - nil) +(cl-defmethod erc-networks--id-given (_) nil) ; _ may be nil (cl-defmethod erc-networks--id-given ((nid erc-networks--id-fixed)) (erc-networks--id-symbol nid)) @@ -866,22 +865,15 @@ erc-networks--id-create ((_ symbol) &context (erc-obsolete-var erc-reuse-buffers null)) (erc-networks--id-fixed-create (intern (buffer-name)))) -(cl-defgeneric erc-networks--id-on-connect (net-id) - "Update NET-ID `erc-networks--id' after connection params known. -This is typically during or just after MOTD.") - -(cl-defmethod erc-networks--id-on-connect ((_ erc-networks--id)) - nil) - -(cl-defmethod erc-networks--id-on-connect ((id erc-networks--id-qualifying)) - (erc-networks--id-qualifying-update id (erc-networks--id-qualifying-create))) - (cl-defgeneric erc-networks--id-equal-p (self other) - "Return non-nil when two network identities exhibit underlying equality. -SELF and OTHER are `erc-networks--id' struct instances. This -should normally be used only for ID recovery or merging, after -which no two identities should be `equal' (timestamps aside) that -aren't also `eq'.") + "Return non-nil when two network IDs exhibit underlying equality. +Expect SELF and OTHER to be `erc-networks--id' struct instances +and that this will only be called for ID recovery or merging, +after which no two identities should be `equal' (timestamps +aside) that aren't also `eq'.") + +(cl-defmethod erc-networks--id-equal-p ((_ null) (_ erc-networks--id)) nil) +(cl-defmethod erc-networks--id-equal-p ((_ erc-networks--id) (_ null)) nil) (cl-defmethod erc-networks--id-equal-p ((self erc-networks--id) (other erc-networks--id)) @@ -1382,7 +1374,8 @@ erc-networks--update-server-identity (let* ((identity erc-networks--id) (buffer (current-buffer)) (f (lambda () - (unless (or (eq (current-buffer) buffer) + (unless (or (not erc-networks--id) + (eq (current-buffer) buffer) (eq erc-networks--id identity)) (if (erc-networks--id-equal-p identity erc-networks--id) (throw 'buffer erc-networks--id) @@ -1397,16 +1390,17 @@ erc-networks--update-server-identity ;; server buffer, whereas `erc-networks--rename-server-buffer' can run ;; mid-session, after an identity's core components have changed. -(defun erc-networks--init-identity (_proc _parsed) +(defun erc-networks--init-identity (proc parsed) "Update identity with real network name." ;; Initialize identity for real now that we know the network (cl-assert erc-network) - (unless (erc-networks--id-symbol erc-networks--id) ; unless just reconnected - (erc-networks--id-on-connect erc-networks--id)) - ;; Find duplicate identities or other conflicting ones and act - ;; accordingly. - (erc-networks--update-server-identity) - ;; + (if erc-networks--id + (erc-networks--id-reload erc-networks--id proc parsed) + (setq erc-networks--id (erc-networks--id-create nil)) + ;; Find duplicate identities or other conflicting ones and act + ;; accordingly. + (erc-networks--update-server-identity) + (erc-networks--rename-server-buffer proc parsed)) nil) (defun erc-networks--rename-server-buffer (new-proc &optional _parsed) @@ -1474,8 +1468,7 @@ erc-networks-on-MOTD-end ;; For now, retain compatibility with erc-server-NNN-functions. (or (erc-networks--ensure-announced proc parsed) (erc-networks--set-name proc parsed) - (erc-networks--init-identity proc parsed) - (erc-networks--rename-server-buffer proc parsed))) + (erc-networks--init-identity proc parsed))) (define-erc-module networks nil "Provide data about IRC networks." diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 2312246e3e..1052c8c4c0 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -2017,10 +2017,12 @@ erc-open (setq erc-default-nicks (if (consp erc-nick) erc-nick (list erc-nick))) ;; client certificate (only useful if connecting over TLS) (setq erc-session-client-certificate client-certificate) - (setq erc-networks--id (if connect - (erc-networks--id-create id) - (buffer-local-value 'erc-networks--id - old-buffer))) + (setq erc-networks--id + (if connect + (or (and continued-session + (buffer-local-value 'erc-networks--id old-buffer)) + (and id (erc-networks--id-create id))) + (buffer-local-value 'erc-networks--id old-buffer))) ;; debug output buffer (setq erc-dbuf (when erc-log-p @@ -3179,7 +3181,8 @@ erc-auth-source-join-function function)) (defun erc--auth-source-determine-params-defaults () - (let* ((net (and-let* ((esid (erc-networks--id-symbol erc-networks--id)) + (let* ((net (and-let* ((erc-networks--id) + (esid (erc-networks--id-symbol erc-networks--id)) ((symbol-name esid))))) (localp (and erc--target (erc--target-channel-local-p erc--target))) (hosts (if localp @@ -5904,7 +5907,13 @@ erc-set-current-nick (with-current-buffer (if (buffer-live-p (erc-server-buffer)) (erc-server-buffer) (current-buffer)) - (setq erc-server-current-nick nick))) + (unless (equal erc-server-current-nick nick) + (setq erc-server-current-nick nick) + ;; This seems sensible but may well be superfluous. Should + ;; really prove that it's actually needed via test scenario. + (when erc-server-connected + (erc-networks--id-reload erc-networks--id))) + nick)) (defun erc-current-nick () "Return the current nickname." diff --git a/test/lisp/erc/erc-scenarios-base-association-nick.el b/test/lisp/erc/erc-scenarios-base-association-nick.el index 3e848be4df..b46c996bc0 100644 --- a/test/lisp/erc/erc-scenarios-base-association-nick.el +++ b/test/lisp/erc/erc-scenarios-base-association-nick.el @@ -25,13 +25,24 @@ (eval-when-compile (require 'erc-join)) -;; You register a new nick, disconnect, and log back in, but your nick -;; is not granted, so ERC obtains a backtick'd version. You open a -;; query buffer for NickServ, and ERC names it using the net-ID (which -;; includes the backtick'd nick) as a suffix. The original -;; (disconnected) NickServ buffer gets renamed with *its* net-ID as -;; well. You then identify to NickServ, and the dead session is no -;; longer considered distinct. +;; You register a new nick in a dedicated query buffer, disconnect, +;; and log back in, but your nick is not granted (maybe you just +;; turned off SASL). In any case, ERC obtains a backtick'd version. +;; You open a query buffer for NickServ, and ERC gives you the +;; existing one. And after you identify, all buffers retain their +;; names, although your net ID has changed internally. +;; +;; If ERC would've instead failed (or intentionally refused) to make +;; the association, you would've ended up with a new NickServ buffer +;; named after the new net ID as a suffix (based on the backtick'd +;; nick), for example, NickServ@foonet/tester`. And the original +;; (disconnected) NickServ buffer would've gotten suffixed with *its* +;; net-ID as well, e.g., NickServ@foonet/tester. And after +;; identifying, you would've seen ERC merge the two as well as their +;; server buffers. While this alternate behavior may arguably be a +;; more honest reflection of reality, it's also quite inconvenient. +;; For a clearer example, see the original version of this file +;; introduced by "Add user-oriented test scenarios for ERC". (ert-deftest erc-scenarios-base-association-nick-bumped () :tags '(:expensive-test) @@ -67,30 +78,29 @@ erc-scenarios-base-association-nick-bumped (funcall expect 5 "ERC finished")))) (with-current-buffer "foonet" - (erc-cmd-RECONNECT)) + (erc-cmd-RECONNECT) + (funcall expect 10 "User modes for tester`")) - (erc-d-t-wait-for 10 "Nick request rejection prevents reassociation (good)" - (get-buffer "foonet/tester`")) + (ert-info ("Server buffer reassociated with new nick") + (should-not (get-buffer "foonet/tester`"))) (ert-info ("Ask NickServ to change nick") - (with-current-buffer "foonet/tester`" - (funcall expect 3 "already in use") + (with-current-buffer "foonet" (funcall expect 3 "debug mode") (erc-cmd-QUERY "NickServ")) - (erc-d-t-wait-for 1 "Dead NickServ query buffer renamed, now qualified" - (get-buffer "NickServ@foonet/tester")) + (ert-info ( "NickServ buffer reassociated") + (should-not (get-buffer "NickServ@foonet/tester`")) + (should-not (get-buffer "NickServ@foonet/tester"))) - (with-current-buffer "NickServ@foonet/tester`" ; new one + (with-current-buffer "NickServ" ; new one (erc-scenarios-common-say "IDENTIFY tester changeme") - (funcall expect 5 "You're now logged in as tester") - (ert-info ("Original buffer found, reused") - (erc-d-t-wait-for 2 (equal (buffer-name) "NickServ"))))) + (funcall expect 5 "You're now logged in as tester"))) - (ert-info ("Ours is the only NickServ buffer that remains") + (ert-info ("Still just one NickServ buffer") (should-not (cdr (erc-scenarios-common-buflist "NickServ")))) - (ert-info ("Visible network ID truncated to one component") + (ert-info ("As well as one server buffer") (should (not (get-buffer "foonet/tester`"))) (should (not (get-buffer "foonet/tester"))) (should (get-buffer "foonet"))))) @@ -135,29 +145,29 @@ erc-scenarios-base-association-nick-bumped-mandated-renick ;; Since we use reconnect, a new buffer won't be created ;; TODO add variant with clean `erc' invocation (with-current-buffer "foonet" - (erc-cmd-RECONNECT)) + (erc-cmd-RECONNECT) + (funcall expect 10 "User modes for dummy")) - (ert-info ("Server-initiated renick") - (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "foonet/dummy")) - (should-not (get-buffer "foonet/tester")) - (funcall expect 15 "debug mode")) + (ert-info ("Server-initiated renick associated correctly") + (with-current-buffer "foonet" + (funcall expect 15 "debug mode") + (should-not (get-buffer "foonet/dummy")) + (should-not (get-buffer "foonet/tester"))) - (erc-d-t-wait-for 1 "Old query renamed, now qualified" - (get-buffer "bob@foonet/tester")) + (ert-info ("Old query reassociated") + (should (get-buffer "bob")) + (should-not (get-buffer "bob@foonet/tester")) + (should-not (get-buffer "bob@foonet/dummy"))) - (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "bob@foonet/dummy")) + (with-current-buffer "foonet" (erc-cmd-NICK "tester") - (ert-info ("Buffers combined") - (erc-d-t-wait-for 2 (equal (buffer-name) "bob"))))) + (funcall expect 5 "You're now logged in as tester"))) - (with-current-buffer "foonet" - (funcall expect 5 "You're now logged in as tester")) - - (ert-info ("Ours is the only bob buffer that remains") + (ert-info ("Ours is still the only bob buffer that remains") (should-not (cdr (erc-scenarios-common-buflist "bob")))) - (ert-info ("Visible network ID truncated to one component") - (should (not (get-buffer "foonet/dummy"))) - (should (get-buffer "foonet"))))) + (ert-info ("Visible network ID still truncated to one component") + (should (not (get-buffer "foonet/tester"))) + (should (not (get-buffer "foonet/dummy")))))) ;;; erc-scenarios-base-association-nick.el ends here commit 71397175aaa51571ba89a2ebf147ae833da5decf Author: F. Jason Park Date: Mon Sep 19 21:28:52 2022 -0700 Add GS2 authorization to sasl-scram-rfc * lisp/net/sasl-scram-rfc.el (sasl-scram-gs2-header-function, sasl-scram-construct-gs2-header): Add new variable and default function for determining a SCRAM GSS-API message header. This is mainly intended for other libraries rather than end users. (sasl-scram-client-first-message): Use gs2-header function. (sasl-scram--client-final-message): Use dedicated gs2-header function. Also remove whitespace when base64-encoding, as per RFC 5802. (Bug#57956.) diff --git a/lisp/net/sasl-scram-rfc.el b/lisp/net/sasl-scram-rfc.el index ee52ed6e07..f7a2e42541 100644 --- a/lisp/net/sasl-scram-rfc.el +++ b/lisp/net/sasl-scram-rfc.el @@ -45,14 +45,21 @@ ;;; Generic for SCRAM-* +(defvar sasl-scram-gs2-header-function 'sasl-scram-construct-gs2-header + "Function to create GS2 header. +See https://www.rfc-editor.org/rfc/rfc5801#section-4.") + +(defun sasl-scram-construct-gs2-header (client) + ;; The "n," means the client doesn't support channel binding, and + ;; the trailing comma is included as per RFC 5801. + (let ((authzid (sasl-client-property client 'authenticator-name))) + (concat "n," (and authzid "a=") authzid ","))) + (defun sasl-scram-client-first-message (client _step) (let ((c-nonce (sasl-unique-id))) (sasl-client-set-property client 'c-nonce c-nonce)) (concat - ;; n = client doesn't support channel binding - "n," - ;; TODO: where would we get authorization id from? - "," + (funcall sasl-scram-gs2-header-function client) (sasl-scram--client-first-message-bare client))) (defun sasl-scram--client-first-message-bare (client) @@ -77,11 +84,11 @@ sasl-scram--client-final-message (c-nonce (sasl-client-property client 'c-nonce)) ;; no channel binding, no authorization id - (cbind-input "n,,")) + (cbind-input (funcall sasl-scram-gs2-header-function client))) (unless (string-prefix-p c-nonce nonce) (sasl-error "Invalid nonce from server")) (let* ((client-final-message-without-proof - (concat "c=" (base64-encode-string cbind-input) "," + (concat "c=" (base64-encode-string cbind-input t) "," "r=" nonce)) (password ;; TODO: either apply saslprep or disallow non-ASCII characters @@ -113,7 +120,7 @@ sasl-scram--client-final-message (client-proof (funcall string-xor client-key client-signature)) (client-final-message (concat client-final-message-without-proof "," - "p=" (base64-encode-string client-proof)))) + "p=" (base64-encode-string client-proof t)))) (sasl-client-set-property client 'auth-message auth-message) (sasl-client-set-property client 'salted-password salted-password) client-final-message))) commit d47e05219f963c28be3b018f31d232aa8eeb200f Author: Theodor Thornhill Date: Tue Nov 22 21:48:21 2022 +0100 Add csharp-mode and csharp-ts-mode * etc/NEWS: Mention new modes. * lisp/progmodes/csharp-mode.el (csharp-mode, csharp-ts-mode): New major modes. diff --git a/etc/NEWS b/etc/NEWS index d235a78e47..8cb54ca740 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -2991,6 +2991,14 @@ A major mode based on the tree-sitter library for editing programs in the JSON language. It includes support for font-locking, indentation, Imenu, which-func, and navigation. +** New mode 'csharp-ts-mode'. +A major mode based on the tree-sitter library for editing programs +in the C# language. It includes support for font-locking, +indentation, Imenu, which-func, and navigation. + +** New mode 'csharp-mode'. +A major mode based on CC Mode for editing programs in the C# language. + * Incompatible Lisp Changes in Emacs 29.1 diff --git a/lisp/progmodes/csharp-mode.el b/lisp/progmodes/csharp-mode.el new file mode 100644 index 0000000000..23d7b05d50 --- /dev/null +++ b/lisp/progmodes/csharp-mode.el @@ -0,0 +1,964 @@ +;;; csharp-mode.el --- Support for editing C# -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. + +;; Author : Theodor Thornhill +;; Maintainer : Theodor Thornhill +;; Created : September 2022 +;; Keywords : c# languages oop + +;; This file is part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Code: + +(require 'compile) +(require 'cc-mode) +(require 'cc-langs) + +(eval-when-compile + (require 'cc-fonts)) + +(defgroup csharp nil + "Major mode for editing C# code." + :group 'prog-mode) + +(eval-and-compile + (defconst csharp--regex-identifier + "[A-Za-z][A-Za-z0-9_]*" + "Regex describing an dentifier in C#.") + + (defconst csharp--regex-identifier-matcher + (concat "\\(" csharp--regex-identifier "\\)") + "Regex matching an identifier in C#.") + + (defconst csharp--regex-type-name + "[A-Z][A-Za-z0-9_]*" + "Regex describing a type identifier in C#.") + + (defconst csharp--regex-type-name-matcher + (concat "\\(" csharp--regex-type-name "\\)") + "Regex matching a type identifier in C#.") + + (defconst csharp--regex-using-or-namespace + (concat "^using" "\\|" "namespace" + "\\s *" + csharp--regex-type-name-matcher) + "Regex matching identifiers after a using or namespace + declaration.")) + +(eval-and-compile + (c-add-language 'csharp-mode 'java-mode) + + (defun csharp--make-mode-syntax-table () + (let ((table (make-syntax-table))) + (c-populate-syntax-table table) + (modify-syntax-entry ?@ "_" table) + table)) + (defvar csharp--make-mode-syntax-table #'csharp--make-mode-syntax-table + "Workaround for Emacs bug#57065.")) + +(c-lang-defconst c-make-mode-syntax-table + csharp #'csharp--make-mode-syntax-table) + +(c-lang-defconst c-identifier-syntax-modifications + csharp (append '((?@ . "w")) + (c-lang-const c-identifier-syntax-modifications))) + +(c-lang-defconst c-symbol-start + csharp (concat "[" c-alpha "_@]")) + +(c-lang-defconst c-opt-type-suffix-key + csharp (concat "\\(\\[" (c-lang-const c-simple-ws) "*\\]\\|\\?\\)")) + +(c-lang-defconst c-identifier-ops + csharp '((left-assoc "."))) + +(c-lang-defconst c-overloadable-operators + csharp '("+" "-" "*" "/" "%" "&" "|" "^" "<<" ">>" "==" + "!=" ">" "<" ">=" "<=")) + +(c-lang-defconst c-multiline-string-start-char + csharp ?@) + +(c-lang-defconst c-ml-string-opener-re + ;; "\\(\\(?:@\\$?\\)\\(\"\\)\\)" + csharp + (rx + (group + (or "@" "@$") + (group "\"")))) + +(c-lang-defconst c-ml-string-max-opener-len + csharp 3) + +(c-lang-defconst c-ml-string-max-closer-len + csharp 2) + +(c-lang-defconst c-ml-string-any-closer-re + ;; "\\(?:\"\"\\)*\\(\\(\"\\)\\)\\(?:[^\"]\\|\\'\\)" + csharp + (rx + (seq + (zero-or-more "\"\"") + (group + (group "\"")) + (or (not (any "\"")) eos)))) + +(c-lang-defconst c-ml-string-back-closer-re + ;; "\\(?:\\`\\|[^\"]\\)\"*" + csharp + (rx + (seq + (or bos + (not (any "\""))) + (zero-or-more "\"")))) + +(c-lang-defconst c-type-prefix-kwds + csharp '("class" "interface" "struct")) + +(c-lang-defconst c-class-decl-kwds + csharp '("class" "interface" "struct")) + +;;; Keyword lists + +(c-lang-defconst c-primitive-type-kwds + csharp '("bool" "byte" "sbyte" "char" "decimal" "double" "float" "int" "uint" + "long" "ulong" "short" "ushort" "void" "object" "string" "var")) + +(c-lang-defconst c-other-decl-kwds + csharp nil) + +(c-lang-defconst c-type-list-kwds + csharp nil) + +(c-lang-defconst c-other-block-decl-kwds + csharp nil) + +(c-lang-defconst c-return-kwds + csharp '("return")) + +(c-lang-defconst c-typedef-kwds + csharp nil) + +(c-lang-defconst c-typeof-kwds + csharp '("typeof" "is" "as")) + +(c-lang-defconst c-type-modifier-prefix-kwds + csharp '("volatile")) + +(c-lang-defconst c-type-modifier-kwds + csharp '("readonly" "new")) + +(c-lang-defconst c-brace-list-decl-kwds + csharp '("enum" "new")) + +(c-lang-defconst c-recognize-post-brace-list-type-p + csharp t) + +(c-lang-defconst c-ref-list-kwds + csharp nil) + +(c-lang-defconst c-using-kwds + csharp '("using")) + +(c-lang-defconst c-equals-type-clause-kwds + csharp '("using")) + +(defun csharp-at-vsemi-p (&optional pos) + (if pos (goto-char pos)) + (save-excursion + (beginning-of-line) + (c-forward-syntactic-ws) + (looking-at "using\\s *("))) + +(c-lang-defconst c-at-vsemi-p-fn + csharp 'csharp-at-vsemi-p) + +(defun csharp-vsemi-status-unknown () t) + +(c-lang-defconst c-vsemi-status-unknown-p-fn + csharp 'csharp-vsemi-status-unknown-p) + + +(c-lang-defconst c-modifier-kwds + csharp '("abstract" "default" "final" "native" "private" "protected" + "public" "partial" "internal" "readonly" "static" "event" "transient" + "volatile" "sealed" "ref" "out" "virtual" "implicit" "explicit" + "fixed" "override" "params" "async" "await" "extern" "unsafe" + "get" "set" "this" "const" "delegate")) + +(c-lang-defconst c-other-kwds + csharp '("select" "from" "where" "join" "in" "on" "equals" "into" + "orderby" "ascending" "descending" "group" "when" + "let" "by" "namespace")) + +(c-lang-defconst c-colon-type-list-kwds + csharp '("class" "struct" "interface")) + +(c-lang-defconst c-block-stmt-1-kwds + csharp '("do" "else" "finally" "try")) + +(c-lang-defconst c-block-stmt-1-2-kwds + csharp '("try")) + +(c-lang-defconst c-block-stmt-2-kwds + csharp '("for" "if" "switch" "while" "catch" "foreach" "fixed" "checked" + "unchecked" "using" "lock")) + +(c-lang-defconst c-simple-stmt-kwds + csharp '("break" "continue" "goto" "throw" "return" "yield")) + +(c-lang-defconst c-constant-kwds + csharp '("true" "false" "null" "value")) + +(c-lang-defconst c-primary-expr-kwds + csharp '("this" "base" "operator")) + +(c-lang-defconst c-inexpr-class-kwds + csharp nil) + +(c-lang-defconst c-class-decl-kwds + csharp '("class" "struct" "interface")) + +(c-lang-defconst c-std-abbrev-keywords + csharp (append (c-lang-const c-std-abbrev-keywords) '("catch" "finally"))) + +(c-lang-defconst c-decl-prefix-re + csharp "\\([{}(;,<]+\\)") + +(c-lang-defconst c-recognize-typeless-decls + csharp t) + +(c-lang-defconst c-recognize-<>-arglists + csharp t) + +(c-lang-defconst c-opt-cpp-prefix + csharp "\\s *#\\s *") + +(c-lang-defconst c-opt-cpp-macro-define + csharp (if (c-lang-const c-opt-cpp-prefix) + "define")) + +(c-lang-defconst c-cpp-message-directives + csharp '("error" "warning" "region")) + +(c-lang-defconst c-cpp-expr-directives + csharp '("if" "elif")) + +(c-lang-defconst c-other-op-syntax-tokens + csharp (append '("#") + (c-lang-const c-other-op-syntax-tokens))) + +(c-lang-defconst c-line-comment-starter + csharp "//") + +(c-lang-defconst c-doc-comment-start-regexp + csharp "///") + +(c-add-style "csharp" + '("java" + (c-basic-offset . 4) + (c-comment-only-line-offset . (0 . 0)) + (c-offsets-alist . ((inline-open . 0) + (arglist-intro . +) + (arglist-close . 0) + (inexpr-class . 0) + (case-label . +) + (cpp-macro . c-lineup-dont-change) + (substatement-open . 0))))) + +(eval-and-compile + (unless (or (stringp c-default-style) + (assoc 'csharp-mode c-default-style)) + (setq c-default-style + (cons '(csharp-mode . "csharp") + c-default-style)))) + +(defun csharp--color-forwards (font-lock-face) + (let (id-beginning) + (goto-char (match-beginning 0)) + (forward-word) + (while (and (not (or (eq (char-after) ?\;) + (eq (char-after) ?\{))) + (progn + (forward-char) + (c-forward-syntactic-ws) + (setq id-beginning (point)) + (> (skip-chars-forward + (c-lang-const c-symbol-chars)) + 0)) + (not (get-text-property (point) 'face))) + (c-put-font-lock-face id-beginning (point) font-lock-face) + (c-forward-syntactic-ws)))) + +(c-lang-defconst c-basic-matchers-before + csharp `( + ;; Warning face on unclosed strings + ,@(if (version< emacs-version "27.0") + ;; Taken from 26.1 branch + `(,(c-make-font-lock-search-function + (concat ".\\(" c-string-limit-regexp "\\)") + '((c-font-lock-invalid-string)))) + `(("\\s|" 0 font-lock-warning-face t nil))) + + ;; Invalid single quotes + c-font-lock-invalid-single-quotes + + ;; Keyword constants + ,@(when (c-lang-const c-constant-kwds) + (let ((re (c-make-keywords-re nil (c-lang-const c-constant-kwds)))) + `((eval . (list ,(concat "\\<\\(" re "\\)\\>") + 1 c-constant-face-name))))) + + ;; Keywords except the primitive types. + ,`(,(concat "\\<" (c-lang-const c-regular-keywords-regexp)) + 1 font-lock-keyword-face) + + ;; Chained identifiers in using/namespace statements + ,`(,(c-make-font-lock-search-function + csharp--regex-using-or-namespace + `((csharp--color-forwards font-lock-variable-name-face) + nil + (goto-char (match-end 0))))) + + + ;; Negation character + (eval . (list "\\(!\\)[^=]" 1 c-negation-char-face-name)) + + ;; Types after 'new' + (eval . (list (concat "\\ *" csharp--regex-type-name-matcher) + 1 font-lock-type-face)) + + ;; Single identifier in attribute + (eval . (list (concat "\\[" csharp--regex-type-name-matcher "\\][^;]") + 1 font-lock-variable-name-face t)) + + ;; Function names + (eval . (list "\\([A-Za-z0-9_]+\\)\\(<[a-zA-Z0-9, ]+>\\)?(" + 1 font-lock-function-name-face)) + + ;; Nameof + (eval . (list (concat "\\(\\\\) *(") + 1 font-lock-function-name-face)) + + (eval . (list (concat "\\ *( *" + csharp--regex-identifier-matcher + " *) *") + 1 font-lock-variable-name-face)) + + ;; Catch statements with type only + (eval . (list (concat "\\ *( *" + csharp--regex-type-name-matcher + " *) *") + 1 font-lock-type-face)) + )) + +(c-lang-defconst c-basic-matchers-after + csharp (append + ;; Merge with cc-mode defaults - enables us to add more later + (c-lang-const c-basic-matchers-after))) + +(defcustom csharp-codedoc-tag-face 'c-doc-markup-face-name + "Face to be used on the codedoc docstring tags. + +Should be one of the font lock faces, such as +`font-lock-variable-name-face' and friends. + +Needs to be set before `csharp-mode' is loaded, because of +compilation and evaluation time conflicts." + :type 'symbol) + +(defcustom csharp-font-lock-extra-types + (list csharp--regex-type-name) + (c-make-font-lock-extra-types-blurb "C#" "csharp-mode" (concat)) + :type 'c-extra-types-widget + :group 'c) + +(defconst csharp-font-lock-keywords-1 (c-lang-const c-matchers-1 csharp) + "Minimal font locking for C# mode.") + +(defconst csharp-font-lock-keywords-2 (c-lang-const c-matchers-2 csharp) + "Fast normal font locking for C# mode.") + +(defconst csharp-font-lock-keywords-3 (c-lang-const c-matchers-3 csharp) + "Accurate normal font locking for C# mode.") + +(defvar csharp-font-lock-keywords csharp-font-lock-keywords-3 + "Default expressions to highlight in C# mode.") + +(defun csharp-font-lock-keywords-2 () + (c-compose-keywords-list csharp-font-lock-keywords-2)) +(defun csharp-font-lock-keywords-3 () + (c-compose-keywords-list csharp-font-lock-keywords-3)) +(defun csharp-font-lock-keywords () + (c-compose-keywords-list csharp-font-lock-keywords)) + +;;; Doc comments + +(defconst codedoc-font-lock-doc-comments + ;; Most of this is taken from the javadoc example, however, we don't use the + ;; '@foo' syntax, so I removed that. Supports the XML tags only + `((,(concat "") + 0 ,csharp-codedoc-tag-face prepend nil) + ;; ("\\([a-zA-Z0-9_]+\\)=" 0 font-lock-variable-name-face prepend nil) + ;; ("\".*\"" 0 font-lock-string-face prepend nil) + ("&\\(\\sw\\|[.:]\\)+;" ; XML entities. + 0 ,csharp-codedoc-tag-face prepend nil))) + +(defconst codedoc-font-lock-keywords + `((,(lambda (limit) + (c-font-lock-doc-comments "///" limit + codedoc-font-lock-doc-comments))))) + +;;; End of doc comments + +;;; Adding syntax constructs + +(advice-add 'c-looking-at-inexpr-block + :around #'csharp-looking-at-inexpr-block) + +(defun csharp-looking-at-inexpr-block (orig-fun &rest args) + (let ((res (csharp-at-lambda-header))) + (if res + res + (apply orig-fun args)))) + +(defun csharp-at-lambda-header () + (save-excursion + (c-backward-syntactic-ws) + (unless (bobp) + (backward-char) + (c-safe (goto-char (scan-sexps (point) -1))) + (when (or (looking-at "([[:alnum:][:space:]_,]*)[ \t\n]*=>[ \t\n]*{") + (looking-at "[[:alnum:]_]+[ \t\n]*=>[ \t\n]*{")) + ;; If we are at a C# lambda header + (cons 'inexpr (point)))))) + +(advice-add 'c-guess-basic-syntax + :around #'csharp-guess-basic-syntax) + +(defun csharp-guess-basic-syntax (orig-fun &rest args) + (cond + (;; Attributes + (save-excursion + (goto-char (c-point 'iopl)) + (and + (eq (char-after) ?\[) + (save-excursion + (c-go-list-forward) + (and (eq (char-before) ?\]) + (not (eq (char-after) ?\;)))))) + `((annotation-top-cont ,(c-point 'iopl)))) + + ((and + ;; Heuristics to find object initializers + (save-excursion + ;; Next non-whitespace character should be '{' + (goto-char (c-point 'boi)) + (eq (char-after) ?{)) + (save-excursion + ;; 'new' should be part of the line + (goto-char (c-point 'iopl)) + (looking-at ".*\\s *new\\s *.*")) + ;; Line should not already be terminated + (save-excursion + (goto-char (c-point 'eopl)) + (or (not (eq (char-before) ?\;)) + (not (eq (char-before) ?\{))))) + (if (save-excursion + ;; if we have a hanging brace on line before + (goto-char (c-point 'eopl)) + (eq (char-before) ?\{)) + `((brace-list-intro ,(c-point 'iopl))) + `((block-open) (statement ,(c-point 'iopl))))) + (t + (apply orig-fun args)))) + +;;; End of new syntax constructs + + + +;;; Fix for strings on version 27.1 + +(when (version= emacs-version "27.1") + ;; See: + ;; https://github.com/emacs-csharp/csharp-mode/issues/175 + ;; https://github.com/emacs-csharp/csharp-mode/issues/151 + ;; for the full story. + (defun c-pps-to-string-delim (end) + (let* ((start (point)) + (no-st-s `(0 nil nil ?\" nil nil 0 nil ,start nil nil)) + (st-s `(0 nil nil t nil nil 0 nil ,start nil nil)) + no-st-pos st-pos + ) + (parse-partial-sexp start end nil nil no-st-s 'syntax-table) + (setq no-st-pos (point)) + (goto-char start) + (while (progn + (parse-partial-sexp (point) end nil nil st-s 'syntax-table) + (unless (bobp) + (c-clear-syn-tab (1- (point)))) + (setq st-pos (point)) + (and (< (point) end) + (not (eq (char-before) ?\"))))) + (goto-char (min no-st-pos st-pos)) + nil)) + + (defun c-multiline-string-check-final-quote () + (let (pos-ll pos-lt) + (save-excursion + (goto-char (point-max)) + (skip-chars-backward "^\"") + (while + (and + (not (bobp)) + (cond + ((progn + (setq pos-ll (c-literal-limits) + pos-lt (c-literal-type pos-ll)) + (memq pos-lt '(c c++))) + ;; In a comment. + (goto-char (car pos-ll))) + ((save-excursion + (backward-char) ; over " + (c-is-escaped (point))) + ;; At an escaped string. + (backward-char) + t) + (t + ;; At a significant " + (c-clear-syn-tab (1- (point))) + (setq pos-ll (c-literal-limits) + pos-lt (c-literal-type pos-ll)) + nil))) + (skip-chars-backward "^\"")) + (cond + ((bobp)) + ((eq pos-lt 'string) + (c-put-syn-tab (1- (point)) '(15))) + (t nil)))))) + +;;; End of fix for strings on version 27.1 + +;; When invoked by MSBuild, csc’s errors look like this: +;; subfolder\file.cs(6,18): error CS1006: Name of constructor must +;; match name of class [c:\Users\user\project.csproj] + +(defun csharp--compilation-error-file-resolve () + "Resolve an msbuild error to a (filename . dirname) cons cell." + ;; http://stackoverflow.com/a/18049590/429091 + (cons (match-string 1) (file-name-directory (match-string 4)))) + +(defconst csharp-compilation-re-msbuild-error + (concat + "^[[:blank:]]*\\(?:[[:digit:]]+>\\)?" + "\\([^(\r\n)]+\\)(\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)?): " + "error [[:alnum:]]+: [^\r\n]+\\[\\([^]\r\n]+\\)\\]$") + "Regexp to match compilation error from msbuild.") + +(defconst csharp-compilation-re-msbuild-warning + (concat + "^[[:blank:]]*\\(?:[[:digit:]]+>\\)?" + "\\([^(\r\n)]+\\)(\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)?): " + "warning [[:alnum:]]+: [^\r\n]+\\[\\([^]\r\n]+\\)\\]$") + "Regexp to match compilation warning from msbuild.") + +;; Notes on xbuild and devenv commonalities +;; +;; These regexes were tailored for xbuild, but apart from the concurrent +;; build-marker ("1>") they share exactly the same match-markers. +;; +;; If we don't exclude the match-markers explicitly, these regexes +;; will also be used to match for devenv as well, including the build-marker +;; in the file-name, causing the lookup to fail. +;; +;; So if we don't want devenv to fail, we actually need to handle it in our +;; xbuild-regexes, but then we automatically get devenv-support for free. + +(defconst csharp-compilation-re-xbuild-error + (concat + "^[[:blank:]]*\\(?:[[:digit:]]+>\\)?" + "\\([^(\r\n)]+\\)(\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)?" + ;; handle weird devenv output format with 4 numbers, not 2 by having optional + ;; extra capture-groups. + "\\(?:,\\([0-9]+\\)\\)*): " + "error [[:alnum:]]+: .+$") + "Regexp to match compilation error from xbuild.") + +(defconst csharp-compilation-re-xbuild-warning + (concat + "^[[:blank:]]*\\(?:[[:digit:]]+>\\)?" + "\\([^(\r\n)]+\\)(\\([0-9]+\\)\\(?:,\\([0-9]+\\)\\)?" + ;; handle weird devenv output format with 4 numbers, not 2 by having optional + ;; extra capture-groups. + "\\(?:,\\([0-9]+\\)\\)?*): " + "warning [[:alnum:]]+: .+$") + "Regexp to match compilation warning from xbuild.") + +(defconst csharp-compilation-re-dotnet-error + "\\([^\r\n]+\\) : error [A-Z]+[0-9]+:") + +(defconst csharp-compilation-re-dotnet-warning + "\\([^\r\n]+\\) : warning [A-Z]+[0-9]+:") + +(defconst csharp-compilation-re-dotnet-testfail + (concat + "[[:blank:]]+Stack Trace:\n" + "[[:blank:]]+at [^\n]+ in \\([^\n]+\\):line \\([0-9]+\\)")) + + +(eval-after-load 'compile + (lambda () + (dolist + (regexp + `((dotnet-testfail + ,csharp-compilation-re-dotnet-testfail + 1 2) + (xbuild-error + ,csharp-compilation-re-xbuild-error + 1 2 3 2) + (xbuild-warning + ,csharp-compilation-re-xbuild-warning + 1 2 3 1) + (msbuild-error + ,csharp-compilation-re-msbuild-error + csharp--compilation-error-file-resolve + 2 + 3 + 2 + nil + (1 compilation-error-face) + (4 compilation-error-face)) + (msbuild-warning + ,csharp-compilation-re-msbuild-warning + csharp--compilation-error-file-resolve + 2 + 3 + 1 + nil + (1 compilation-warning-face) + (4 compilation-warning-face)) + (dotnet-error + ,csharp-compilation-re-dotnet-error + 1) + (dotnet-warning + ,csharp-compilation-re-dotnet-warning + 1 nil nil 1))) + (add-to-list 'compilation-error-regexp-alist-alist regexp) + (add-to-list 'compilation-error-regexp-alist (car regexp))))) + +(defvar csharp-mode-syntax-table + (funcall (c-lang-const c-make-mode-syntax-table csharp)) + "Syntax table used in `csharp-mode' buffers.") + +(defvar csharp-mode-map + (let ((map (c-make-inherited-keymap))) + map) + "Keymap used in `csharp-mode' buffers.") + +(easy-menu-define csharp-mode-menu csharp-mode-map "C# Mode Commands." + (cons "C#" (c-lang-const c-mode-menu csharp))) + +;;; Tree-sitter support + +(defcustom csharp-ts-mode-indent-offset 4 + "Number of spaces for each indentation step in `csharp-ts-mode'." + :type 'integer + :safe 'integerp + :group 'csharp) + +(defvar csharp-ts-mode--indent-rules + `((c-sharp + ((parent-is "compilation_unit") parent-bol 0) + ((node-is "}") parent-bol 0) + ((node-is ")") parent-bol 0) + ((node-is "]") parent-bol 0) + ((parent-is "namespace_declaration") parent-bol 0) + ((parent-is "class_declaration") parent-bol 0) + ((parent-is "constructor_declaration") parent-bol 0) + ((parent-is "method_declaration") parent-bol 0) + ((parent-is "enum_declaration") parent-bol 0) + ((parent-is "operator_declaration") parent-bol 0) + ((parent-is "field_declaration") parent-bol 0) + ((parent-is "struct_declaration") parent-bol 0) + ((parent-is "declaration_list") parent-bol csharp-ts-mode-indent-offset) + ((parent-is "argument_list") parent-bol csharp-ts-mode-indent-offset) + ((parent-is "interpolation") parent-bol csharp-ts-mode-indent-offset) + ((parent-is "binary_expression") parent 0) + ((parent-is "block") parent-bol csharp-ts-mode-indent-offset) + ((parent-is "local_function_statement") parent-bol 0) + ((parent-is "if_statement") parent-bol 0) + ((parent-is "for_statement") parent-bol 0) + ((parent-is "for_each_statement") parent-bol 0) + ((parent-is "while_statement") parent-bol 0) + ((match "{" "switch_expression") parent-bol 0) + ((parent-is "switch_statement") parent-bol 0) + ((parent-is "switch_body") parent-bol csharp-ts-mode-indent-offset) + ((parent-is "switch_section") parent-bol csharp-ts-mode-indent-offset) + ((parent-is "switch_expression") parent-bol csharp-ts-mode-indent-offset) + ((parent-is "case_statement") parent-bol 0) + ((parent-is "do_statement") parent-bol 0) + ((parent-is "equals_value_clause") parent-bol csharp-ts-mode-indent-offset) + ((parent-is "ternary_expression") parent-bol csharp-ts-mode-indent-offset) + ((parent-is "conditional_expression") parent-bol csharp-ts-mode-indent-offset) + ((parent-is "statement_block") parent-bol csharp-ts-mode-indent-offset) + ((parent-is "type_arguments") parent-bol csharp-ts-mode-indent-offset) + ((parent-is "variable_declarator") parent-bol csharp-ts-mode-indent-offset) + ((parent-is "arguments") parent-bol csharp-ts-mode-indent-offset) + ((parent-is "array") parent-bol csharp-ts-mode-indent-offset) + ((parent-is "formal_parameters") parent-bol csharp-ts-mode-indent-offset) + ((parent-is "template_substitution") parent-bol csharp-ts-mode-indent-offset) + ((parent-is "object_pattern") parent-bol csharp-ts-mode-indent-offset) + ((parent-is "object") parent-bol csharp-ts-mode-indent-offset) + ((parent-is "object_type") parent-bol csharp-ts-mode-indent-offset) + ((parent-is "enum_body") parent-bol csharp-ts-mode-indent-offset) + ((parent-is "arrow_function") parent-bol csharp-ts-mode-indent-offset) + ((parent-is "parenthesized_expression") parent-bol csharp-ts-mode-indent-offset)))) + +(defvar csharp-ts-mode--keywords + '("using" "namespace" "class" "if" "else" "throw" "new" "for" + "return" "await" "struct" "enum" "switch" "case" + "default" "typeof" "try" "catch" "finally" "break" + "foreach" "in" "yield" "get" "set" "when" "as" "out" + "is" "while" "continue" "this" "ref" "goto" "interface" + "from" "where" "select" "lock" "base" "record" "init" + "with" "let" "static" "var" "do" "public" "private" + "readonly" "unmanaged") + "C# keywords for tree-sitter font-locking.") + +(defvar csharp-ts-mode--font-lock-settings + (treesit-font-lock-rules + :language 'c-sharp + :override t + :feature 'comment + '((comment) @font-lock-comment-face) + :language 'c-sharp + :override t + :feature 'keyword + `([,@csharp-ts-mode--keywords] @font-lock-keyword-face + (modifier) @font-lock-keyword-face + (this_expression) @font-lock-keyword-face) + :language 'c-sharp + :override t + :feature 'attribute + `((attribute (identifier) @font-lock-property-face (attribute_argument_list)) + (attribute (identifier) @font-lock-property-face)) + :language 'c-sharp + :override t + :feature 'escape-sequence + '((escape_sequence) @font-lock-escape-face) + :language 'c-sharp + :override t + :feature 'literal + `((integer_literal) @font-lock-constant-face + (real_literal) @font-lock-constant-face + (null_literal) @font-lock-constant-face + (boolean_literal) @font-lock-constant-face) + :language 'c-sharp + :override t + :feature 'string + `([(string_literal) + (verbatim_string_literal) + (interpolated_string_text) + (interpolated_verbatim_string_text) + (character_literal) + "\"" + "$\"" + "@$\"" + "$@\""] @font-lock-string-face) + :language 'c-sharp + :override t + :feature 'type + '((predefined_type) @font-lock-type-face + (implicit_type) @font-lock-type-face + (nullable_type) @font-lock-type-face + (type_parameter + (identifier) @font-lock-type-face) + (type_argument_list + (identifier) @font-lock-type-face) + (generic_name + (identifier) @font-lock-type-face) + (array_type + (identifier) @font-lock-type-face) + (cast_expression (identifier) @font-lock-type-face) + ["operator"] @font-lock-type-face + (type_parameter_constraints_clause + target: (identifier) @font-lock-type-face)) + :language 'c-sharp + :feature 'definition + :override t + '((qualified_name (identifier) @font-lock-variable-name-face) + (using_directive (identifier) @font-lock-type-face) + + (enum_declaration (identifier) @font-lock-type-face) + (enum_member_declaration (identifier) @font-lock-variable-name-face) + + (interface_declaration (identifier) @font-lock-type-face) + + (struct_declaration (identifier) @font-lock-type-face) + + (record_declaration (identifier) @font-lock-type-face) + (namespace_declaration (identifier) @font-lock-type-face) + (base_list (identifier) @font-lock-type-face) + (property_declaration (generic_name)) + (property_declaration + type: (nullable_type) @font-lock-type-face + name: (identifier) @font-lock-variable-name-face) + (property_declaration + type: (predefined_type) @font-lock-type-face + name: (identifier) @font-lock-variable-name-face) + (property_declaration + type: (identifier) @font-lock-type-face + name: (identifier) @font-lock-variable-name-face) + (class_declaration (identifier) @font-lock-type-face) + + (constructor_declaration name: (_) @font-lock-type-face) + + (method_declaration type: (_) @font-lock-type-face) + (method_declaration name: (_) @font-lock-function-name-face) + + (variable_declaration (identifier) @font-lock-type-face) + (variable_declarator (identifier) @font-lock-variable-name-face) + + (parameter type: (identifier) @font-lock-type-face) + (parameter name: (identifier) @font-lock-variable-name-face)) + :language 'c-sharp + :feature 'expression + '((conditional_expression (identifier) @font-lock-variable-name-face) + (postfix_unary_expression (identifier)* @font-lock-variable-name-face) + (assignment_expression (identifier) @font-lock-variable-name-face)) + :language 'c-sharp + :feature 'bracket + '((["(" ")" "[" "]" "{" "}"]) @font-lock-bracket-face) + + :language 'c-sharp + :feature 'delimiter + '((["," ":" ";"]) @font-lock-delimiter-face))) + +;;;###autoload +(add-to-list 'auto-mode-alist '("\\.cs\\'" . csharp-mode)) + +(defun csharp-ts-mode--imenu-1 (node) + "Helper for `csharp-ts-mode--imenu'. +Find string representation for NODE and set marker, then recurse +the subtrees." + (let* ((ts-node (car node)) + (subtrees (mapcan #'csharp-ts-mode--imenu-1 (cdr node))) + (name (when ts-node + (or (treesit-node-text + (or (treesit-node-child-by-field-name + ts-node "name")) + t) + "Unnamed node"))) + (marker (when ts-node + (set-marker (make-marker) + (treesit-node-start ts-node))))) + (cond + ((null ts-node) subtrees) + (subtrees + `((,name ,(cons name marker) ,@subtrees))) + (t + `((,name . ,marker)))))) + +(defun csharp-ts-mode--imenu () + "Return Imenu alist for the current buffer." + (let* ((node (treesit-buffer-root-node)) + (class-tree (treesit-induce-sparse-tree + node "^class_declaration$" nil 1000)) + (interface-tree (treesit-induce-sparse-tree + node "^interface_declaration$" nil 1000)) + (enum-tree (treesit-induce-sparse-tree + node "^enum_declaration$" nil 1000)) + (struct-tree (treesit-induce-sparse-tree + node "^struct_declaration$" nil 1000)) + (record-tree (treesit-induce-sparse-tree + node "^record_declaration$" nil 1000)) + (method-tree (treesit-induce-sparse-tree + node "^method_declaration$" nil 1000)) + (class-index (csharp-ts-mode--imenu-1 class-tree)) + (interface-index (csharp-ts-mode--imenu-1 interface-tree)) + (enum-index (csharp-ts-mode--imenu-1 enum-tree)) + (record-index (csharp-ts-mode--imenu-1 record-tree)) + (struct-index (csharp-ts-mode--imenu-1 struct-tree)) + (method-index (csharp-ts-mode--imenu-1 method-tree))) + (append + (when class-index `(("Class" . ,class-index))) + (when interface-index `(("Interface" . ,interface-index))) + (when enum-index `(("Enum" . ,enum-index))) + (when record-index `(("Record" . ,record-index))) + (when struct-index `(("Struct" . ,struct-index))) + (when method-index `(("Method" . ,method-index)))))) + +;;;###autoload +(add-to-list 'auto-mode-alist '("\\.cs\\'" . csharp-mode)) + +;;;###autoload +(define-derived-mode csharp-mode prog-mode "C#" + "Major mode for editing Csharp code. + +Key bindings: +\\{csharp-mode-map}" + :after-hook (c-update-modeline) + (c-initialize-cc-mode t) + (c-init-language-vars csharp-mode) + (c-common-init 'csharp-mode) + (setq-local c-doc-comment-style '((csharp-mode . codedoc))) + (run-mode-hooks 'c-mode-common-hook)) + +;;;###autoload +(define-derived-mode csharp-ts-mode prog-mode "C#" + "Major mode for editing C# code." + + (unless (treesit-ready-p 'c-sharp) + (error "Tree-sitter for C# isn't available")) + + ;; Tree-sitter. + (treesit-parser-create 'c-sharp) + + ;; Comments. + (setq-local comment-start "// ") + (setq-local comment-start-skip "\\(?://+\\|/\\*+\\)\\s *") + (setq-local comment-end "") + + ;; Indent. + (setq-local treesit-simple-indent-rules csharp-ts-mode--indent-rules) + + ;; Electric + (setq-local electric-indent-chars + (append "{}():;," electric-indent-chars)) + + ;; Navigation. + (setq-local treesit-defun-type-regexp "declaration") + + ;; Font-lock. + (setq-local treesit-font-lock-settings csharp-ts-mode--font-lock-settings) + (setq-local treesit-font-lock-feature-list + '((comment keyword constant string) + (type definition expression literal attribute) + (bracket delimiter))) + + ;; Imenu. + (setq-local imenu-create-index-function #'csharp-ts-mode--imenu) + (setq-local which-func-functions nil) ;; Piggyback on imenu + (treesit-major-mode-setup)) + +(provide 'csharp-mode) + +;;; csharp-mode.el ends here commit 936831579490c2e2a057298f5f915465fbb116d8 Author: Yuan Fu Date: Wed Nov 23 12:08:47 2022 -0800 Don't skip nested defuns in python-ts-mode defun navigation This fixes bug#59495. Before this change, python tries to skip nested function definition. Now we don't skip any nested defun. * lisp/progmodes/python.el (python-treesit-beginning-of-defun) (python-treesit-end-of-defun): Remove functions. * lisp/progmodes/python.el (python-ts-mode): Use tree-sitter's default navigation function. diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 18594a3e23..f97ae81508 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -2395,55 +2395,6 @@ python-nav-if-name-main (point) (ignore (goto-char point))))) - -;;; Tree-sitter navigation - -(defun python-treesit-beginning-of-defun (&optional arg) - "Tree-sitter `beginning-of-defun' function. -ARG is the same as in `beginning-of-defun'." - (let ((arg (or arg 1)) - (node (treesit-node-at (point))) - (function-or-class (rx (or "function" "class") "_definition"))) - (if (> arg 0) - ;; Go backward. - (while (and (> arg 0) - (setq node (treesit-search-forward-goto - node function-or-class t t))) - ;; Here we deviate from `treesit-beginning-of-defun': if - ;; NODE is function_definition, find the top-level - ;; function_definition, if NODE is class_definition, find - ;; the top-level class_definition, don't mix the two like - ;; `treesit-beginning-of-defun' would. - (setq node (or (treesit-node-top-level node) - node)) - (setq arg (1- arg))) - ;; Go forward. - (while (and (< arg 0) - (setq node (treesit-search-forward-goto - node function-or-class))) - (setq node (or (treesit-node-top-level node) - node)) - (setq arg (1+ arg)))) - (when node - (goto-char (treesit-node-start node)) - t))) - -(defun python-treesit-end-of-defun () - "Tree-sitter `end-of-defun' function." - ;; Why not simply get the largest node at point: when point is at - ;; (point-min), that gives us the root node. - (let* ((node (treesit-node-at (point))) - (top-func (treesit-node-top-level - node - "function_definition")) - (top-class (treesit-node-top-level - node - "class_definition"))) - ;; Prefer function_definition over class_definition: when we are - ;; in a function_definition inside a class_definition, jump to the - ;; end of function_definition. - (goto-char (or (treesit-node-end (or top-func top-class)) (point))))) - ;;; Shell integration @@ -6655,9 +6606,8 @@ python-ts-mode (setq-local treesit-font-lock-settings python--treesit-settings) (setq-local imenu-create-index-function #'python-imenu-treesit-create-index) - (setq-local beginning-of-defun-function - #'python-treesit-beginning-of-defun) - (setq-local end-of-defun-function #'python-treesit-end-of-defun) + (setq-local treesit-defun-type-regexp (rx (or "function" "class") + "_definition")) (treesit-major-mode-setup))) ;;; Completion predicates for M-x commit 6785273a8251a2d3dc0450264196f3f19f6403bc Author: Yuan Fu Date: Wed Nov 23 12:07:07 2022 -0800 More flexible tree-sitter defun navigation Before this change, treesit-beginning-of-defun skips nested defuns. Now user can decide whether to skip nested defuns. * lisp/treesit.el (treesit-search-forward-goto): Improve docstring. (treesit-defun-prefer-top-level): New variable. (treesit--defun-maybe-top-level): New function. (treesit-beginning-of-defun) (treesit-end-of-defun): Use treesit--defun-maybe-top-level. diff --git a/lisp/treesit.el b/lisp/treesit.el index 419a705dbf..3140358167 100644 --- a/lisp/treesit.el +++ b/lisp/treesit.el @@ -1492,7 +1492,8 @@ treesit-search-forward-goto This function guarantees that the matched node it returns makes progress in terms of buffer position: the start/end position of -the returned node is always greater than that of NODE. +the returned node is always STRICTLY greater/less than that of +NODE. BACKWARD and ALL are the same as in `treesit-search-forward'." (when-let* ((start-pos (if start @@ -1534,6 +1535,38 @@ treesit-defun-type-regexp This is used by `treesit-beginning-of-defun' and friends.") +(defvar-local treesit-defun-prefer-top-level nil + "When non-nil, `treesit-beginning-of-defun' prefers top-level defun. + +In some languages, a defun (function, class, struct) could be +nested in another one. Normally `treesit-beginning-of-defun' +just finds the first defun it encounter. If this variable's +value is t, `treesit-beginning-of-defun' tries to find the +top-level defun, and ignores nested ones. + +This variable can also be a list of tree-sitter node type +regexps. Then, when `treesit-beginning-of-defun' finds a defun +node and that node's type matches one in the list, +`treesit-beginning-of-defun' finds the top-level node matching +that particular regexp (as opposed to any node matched by +`treesit-defun-type-regexp').") + +(defun treesit--defun-maybe-top-level (node) + "Maybe return the top-level equivalent of NODE. +For the detailed semantic see `treesit-defun-prefer-top-level'." + (pcase treesit-defun-prefer-top-level + ('nil node) + ('t (or (treesit-node-top-level + node treesit-defun-type-regexp) + node)) + ((pred consp) + (cl-loop + for re in treesit-defun-prefer-top-level + if (string-match-p re (treesit-node-type node)) + return (or (treesit-node-top-level node re) + node) + finally return node)))) + (defun treesit-beginning-of-defun (&optional arg) "Tree-sitter `beginning-of-defun' function. ARG is the same as in `beginning-of-defun'." @@ -1544,17 +1577,13 @@ treesit-beginning-of-defun (while (and (> arg 0) (setq node (treesit-search-forward-goto node treesit-defun-type-regexp t t))) - (setq node (or (treesit-node-top-level - node treesit-defun-type-regexp) - node)) + (setq node (treesit--defun-maybe-top-level node)) (setq arg (1- arg))) ;; Go forward. (while (and (< arg 0) (setq node (treesit-search-forward-goto node treesit-defun-type-regexp))) - (setq node (or (treesit-node-top-level - node treesit-defun-type-regexp) - node)) + (setq node (treesit--defun-maybe-top-level node)) (setq arg (1+ arg)))) (when node (goto-char (treesit-node-start node)) @@ -1564,11 +1593,9 @@ treesit-end-of-defun "Tree-sitter `end-of-defun' function." ;; Why not simply get the largest node at point: when point is at ;; (point-min), that gives us the root node. - (let* ((node (treesit-node-at (point))) - (top (or (treesit-node-top-level - node - treesit-defun-type-regexp) - node))) + (let* ((node (treesit-search-forward + (treesit-node-at (point)) treesit-defun-type-regexp t t)) + (top (treesit--defun-maybe-top-level node))) (goto-char (treesit-node-end top)))) ;;; Imenu commit 10f8f9a1851a4bda42dc6f22ae85d09e1693a07e Author: Yuan Fu Date: Wed Nov 23 12:06:40 2022 -0800 ; * src/treesit.c: Minor comment improvement. diff --git a/src/treesit.c b/src/treesit.c index 21e1f866f7..4e07d4d084 100644 --- a/src/treesit.c +++ b/src/treesit.c @@ -2568,7 +2568,8 @@ treesit_traverse_child_helper (TSNode node, bool forward, bool named) } /* Return true if NODE matches PRED. PRED can be a string or a - function. This function doesn't check for PRED's type. */ + function. This function assumes PRED is either a string or a + function. */ static bool treesit_traverse_match_predicate (TSNode node, Lisp_Object pred, Lisp_Object parser) commit b42cd524b46a4f29ef13e9d03be9d3df917f9aa3 Author: Ulf Jasper Date: Wed Nov 23 20:31:42 2022 +0100 icalendar.el: Add test(s) for bug#56241 * test/lisp/calendar/icalendar-tests.el (icalendar-tests--get-error-string-for-export): new. * icalendar-tests.el (icalendar-export-bug-56241-dotted-pair): new diff --git a/test/lisp/calendar/icalendar-tests.el b/test/lisp/calendar/icalendar-tests.el index 2e9353a09b..d9631310ae 100644 --- a/test/lisp/calendar/icalendar-tests.el +++ b/test/lisp/calendar/icalendar-tests.el @@ -61,6 +61,15 @@ icalendar-tests--get-file-contents (ert-resource-file filename)) (buffer-string)))) +(defun icalendar-tests--get-error-string-for-export (diary-string) + "Call icalendar-export for DIARY-STRING and return resulting error-string." + (let ((file (make-temp-file "export.ics"))) + (with-temp-buffer + (insert diary-string) + (icalendar-export-region (point-min) (point-max) file)) + (with-current-buffer (get-buffer "*icalendar-errors*") + (buffer-string)))) + ;; ====================================================================== ;; Tests of functions ;; ====================================================================== @@ -981,6 +990,40 @@ icalendar-export-alarms " '(2 ((email ("att.one@email.com" "att.two@email.com")) (audio) (display))))) +;; ====================================================================== +;; #bug56241 +;; ====================================================================== +(defun icalendar-tests--diary-float (&rest args) + (apply #'diary-float args)) + +(ert-deftest icalendar-export-bug-56241-dotted-pair () + "See https://debbugs.gnu.org/cgi/bugreport.cgi?bug=56241#5" + (let ((icalendar-export-sexp-enumeration-days 366)) + (mapc (lambda (diary-string) + (should (string= "" (icalendar-tests--get-error-string-for-export + diary-string)))) + '("%%(diary-float 7 0 1) First Sunday in July 1" + "%%(icalendar-tests--diary-float 7 0 1) First Sunday in July 2")))) + + +;; (ert-deftest icalendar-export-bug-56241-sexp-does-not-match () +;; "Reported in #bug56241 -- needs to be fixed!" +;; (let ((icalendar-export-sexp-enumeration-days 0)) +;; (mapc (lambda (diary-string) +;; (should (string= "" (icalendar-tests--get-error-string-for-export +;; diary-string)))) +;; '("%%(diary-float 7 0 1) First Sunday in July 1" +;; "%%(icalendar-tests--diary-float 7 0 1) First Sunday in July 2")))) +;; +;; (ert-deftest icalendar-export-bug-56241-nested-sexps () +;; "Reported in #bug56241 -- needs to be fixed!" +;; (let ((icalendar-export-sexp-enumeration-days 366)) +;; (mapc (lambda (diary-string) +;; (should (string= "" (icalendar-tests--get-error-string-for-export +;; diary-string)))) +;; '("%%(= (calendar-day-of-week date) 0) Sunday 1" +;; "%%(= 0 (calendar-day-of-week date)) Sunday 2")))) + ;; ====================================================================== ;; Import tests ;; ====================================================================== commit 21b387c39bd9cf07cddd50d092b5a5bec03ecd1d Author: Juri Linkov Date: Wed Nov 23 20:44:37 2022 +0200 New commands previous-line-completion and next-line-completion (bug#59486) * lisp/simple.el (completion-list-mode-map): Bind [up] to 'previous-line-completion', and [down] to 'next-line-completion'. (completion-auto-wrap): Mention `next-line-completion' and `previous-line-completion' in the docstring. (previous-line-completion, next-line-completion): New commands. diff --git a/etc/NEWS b/etc/NEWS index 5a65896d69..d235a78e47 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1757,9 +1757,10 @@ the second one will switch to the "*Completions*" buffer. --- *** New user option 'completion-auto-wrap'. -When non-nil, the commands 'next-completion' and 'previous-completion' -automatically wrap around on reaching the beginning or the end of -the "*Completions*" buffer. +When non-nil, the commands 'next-completion', 'previous-completion', +'next-line-completion' and 'previous-line-completion' automatically +wrap around on reaching the beginning or the end of the "*Completions*" +buffer. +++ *** New values for the 'completion-auto-help' user option. diff --git a/lisp/simple.el b/lisp/simple.el index 0f44b14948..e868736614 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -9572,6 +9572,8 @@ completion-list-mode-map (define-key map "\C-m" 'choose-completion) (define-key map "\e\e\e" 'delete-completion-window) (define-key map [remap keyboard-quit] #'delete-completion-window) + (define-key map [up] 'previous-line-completion) + (define-key map [down] 'next-line-completion) (define-key map [left] 'previous-completion) (define-key map [right] 'next-completion) (define-key map [?\t] 'next-completion) @@ -9631,8 +9633,10 @@ delete-completion-window (defcustom completion-auto-wrap t "Non-nil means to wrap around when selecting completion options. -This affects the commands `next-completion' and `previous-completion'. -When `completion-auto-select' is t, it wraps through the minibuffer." +This affects the commands `next-completion', `previous-completion', +`next-line-completion' and `previous-line-completion'. +When `completion-auto-select' is t, it wraps through the minibuffer +for the commands bound to the TAB key." :type 'boolean :version "29.1" :group 'completion) @@ -9736,6 +9740,73 @@ next-completion (when (/= 0 n) (switch-to-minibuffer)))) +(defun previous-line-completion (&optional n) + "Move to the item on the previous line in the completion list. +With prefix argument N, move back N items line-wise (negative N +means move forward). + +Also see the `completion-auto-wrap' variable." + (interactive "p") + (next-line-completion (- n))) + +(defun next-line-completion (&optional n) + "Move to the item on the next line in the completion list. +With prefix argument N, move N items line-wise (negative N +means move backward). + +Also see the `completion-auto-wrap' variable." + (interactive "p") + (let ((column (current-column)) + pos) + (catch 'bound + (while (> n 0) + (setq pos nil) + (save-excursion + (while (and (not pos) (not (eobp))) + (forward-line 1) + (when (and (not (eobp)) + (eq (move-to-column column) column) + (get-text-property (point) 'mouse-face)) + (setq pos (point))))) + (if pos (goto-char pos) + (when completion-auto-wrap + (save-excursion + (goto-char (point-min)) + (when (and (eq (move-to-column column) column) + (get-text-property (point) 'mouse-face)) + (setq pos (point))) + (while (and (not pos) (not (eobp))) + (forward-line 1) + (when (and (eq (move-to-column column) column) + (get-text-property (point) 'mouse-face)) + (setq pos (point))))) + (if pos (goto-char pos)))) + (setq n (1- n))) + + (while (< n 0) + (setq pos nil) + (save-excursion + (while (and (not pos) (not (bobp))) + (forward-line -1) + (when (and (not (bobp)) + (eq (move-to-column column) column) + (get-text-property (point) 'mouse-face)) + (setq pos (point))))) + (if pos (goto-char pos) + (when completion-auto-wrap + (save-excursion + (goto-char (point-max)) + (when (and (eq (move-to-column column) column) + (get-text-property (point) 'mouse-face)) + (setq pos (point))) + (while (and (not pos) (not (bobp))) + (forward-line -1) + (when (and (eq (move-to-column column) column) + (get-text-property (point) 'mouse-face)) + (setq pos (point))))) + (if pos (goto-char pos)))) + (setq n (1+ n)))))) + (defun choose-completion (&optional event no-exit no-quit) "Choose the completion at point. If EVENT, use EVENT's position to determine the starting position. commit a3fcc4ed0fa8a14d151620eccc0490b1a83dbf77 Author: Philip Kaludercic Date: Sun Nov 20 15:36:24 2022 +0100 Don't break when loading VC packages on older Emacs versions * lisp/emacs-lisp/package-vc.el (package-vc--generate-description-file): Append a :kind property instead of modifying the version number. * lisp/emacs-lisp/package.el (package-desc): Remove special handling for "vc annotated" versions. (bug#59404) diff --git a/lisp/emacs-lisp/package-vc.el b/lisp/emacs-lisp/package-vc.el index a999596785..bf1ea2bdf4 100644 --- a/lisp/emacs-lisp/package-vc.el +++ b/lisp/emacs-lisp/package-vc.el @@ -334,7 +334,7 @@ package-vc--generate-description-file (nconc (list 'define-package (symbol-name name) - (cons 'vc (package-vc--version pkg-desc)) + (package-vc--version pkg-desc) (package-desc-summary pkg-desc) (let ((requires (package-desc-reqs pkg-desc))) (list 'quote @@ -344,6 +344,7 @@ package-vc--generate-description-file (list (car elt) (package-version-join (cadr elt)))) requires)))) + (list :kind 'vc) (package--alist-to-plist-args (package-desc-extras pkg-desc)))) "\n") diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index c1545a2870..e11c5d693e 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -483,9 +483,7 @@ package-vc-p (if (eq 'quote (car requirements)) (nth 1 requirements) requirements))) - (kind (if (eq (car-safe version-string) 'vc) - 'vc - (plist-get rest-plist :kind))) + (kind (plist-get rest-plist :kind)) (archive (plist-get rest-plist :archive)) (extras (let (alist) (while rest-plist commit 7a4f524314a263f0b935e4f2ce73a416b877d6f8 Author: Juri Linkov Date: Wed Nov 23 20:33:18 2022 +0200 * lisp/help.el (describe-bindings): Use the outline-default-rules feature. Set buffer-local outline-default-state to 1, and outline-default-rules to match "Key translations", instead of searching and hiding this section explicitly. diff --git a/lisp/help.el b/lisp/help.el index f956111a52..8e1b325141 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -747,14 +747,15 @@ describe-bindings (setq-local outline-level (lambda () 1)) (setq-local outline-minor-mode-cycle t outline-minor-mode-highlight t - outline-minor-mode-use-buttons 'insert) + outline-minor-mode-use-buttons 'insert + ;; Hide the longest body. + outline-default-state 1 + outline-default-rules + '((match-regexp . "Key translations"))) (outline-minor-mode 1) (save-excursion (goto-char (point-min)) (let ((inhibit-read-only t)) - ;; Hide the longest body. - (when (re-search-forward "Key translations" nil t) - (outline-hide-subtree)) ;; Hide ^Ls. (while (search-forward "\n\f\n" nil t) (put-text-property (1+ (match-beginning 0)) (1- (match-end 0)) commit 5f9b587e807e20d0716d2cfae14d8ea0ccb9a6c4 Merge: 325515f979 c38f3b1ce1 Author: Eli Zaretskii Date: Wed Nov 23 20:33:26 2022 +0200 Merge branch 'master' of git.savannah.gnu.org:/srv/git/emacs commit 325515f9792321c3ccc183a9e70fe121a5337fc3 Author: Xi Lu Date: Wed Nov 23 23:54:54 2022 +0800 Support Racket programs in 'etags' * lib-src/ctags.c (Scheme_suffixes): Add the Racket language extension ".rkt". Copyright-paperwork-exempt: yes diff --git a/lib-src/etags.c b/lib-src/etags.c index ed8a218464..3107c7b380 100644 --- a/lib-src/etags.c +++ b/lib-src/etags.c @@ -774,7 +774,7 @@ #define STDIN 0x1001 /* returned by getopt_long on --parse-stdin */ /* Can't do the `SCM' or `scm' prefix with a version number. */ static const char *Scheme_suffixes [] = - { "oak", "sch", "scheme", "SCM", "scm", "SM", "sm", "ss", "t", NULL }; + { "oak", "rkt", "sch", "scheme", "SCM", "scm", "SM", "sm", "ss", "t", NULL }; static const char Scheme_help [] = "In Scheme code, tags include anything defined with 'def' or with a\n\ construct whose name starts with 'def'. They also include\n\ commit c38f3b1ce1e554bc7c76efdd1af5fc6c3164fc7b Author: Dmitry Gutov Date: Wed Nov 23 20:24:43 2022 +0200 xref--search-property: Jump over entries hidden by outline-minor-mode * lisp/progmodes/xref.el (xref--search-property): Jump over entries hidden by e.g. outline-minor-mode (bug#49731). diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 139929dc8a..e220367a21 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -346,7 +346,9 @@ xref--search-property (value nil)) (while (progn (goto-char (funcall next (point) property)) - (not (or (setq value (get-text-property (point) property)) + (not (or (and + (memq (get-char-property (point) 'invisible) '(ellipsis nil)) + (setq value (get-text-property (point) property))) (eobp) (bobp))))) (cond (value) commit 275bc7828645312feaa446af959cce5c659123f3 Author: Eli Zaretskii Date: Wed Nov 23 20:22:19 2022 +0200 ; * src/pdumper.c (dump_buffer, dump_vectorlike): Update hashes. diff --git a/src/pdumper.c b/src/pdumper.c index 0a5d96dbb7..fedcd3e404 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2748,7 +2748,7 @@ dump_hash_table (struct dump_context *ctx, static dump_off dump_buffer (struct dump_context *ctx, const struct buffer *in_buffer) { -#if CHECK_STRUCTS && !defined HASH_buffer_193CAA5E45 +#if CHECK_STRUCTS && !defined HASH_buffer_DB34E5D09F # error "buffer changed. See CHECK_STRUCTS comment in config.h." #endif struct buffer munged_buffer = *in_buffer; @@ -3000,7 +3000,7 @@ dump_vectorlike (struct dump_context *ctx, Lisp_Object lv, dump_off offset) { -#if CHECK_STRUCTS && !defined HASH_pvec_type_AFF6FED5BD +#if CHECK_STRUCTS && !defined HASH_pvec_type_5F2059C47E # error "pvec_type changed. See CHECK_STRUCTS comment in config.h." #endif const struct Lisp_Vector *v = XVECTOR (lv); commit 5496f454372a2e4fec651423c41b5ee2a06e0add Author: Eli Zaretskii Date: Wed Nov 23 17:16:32 2022 +0200 Avoid signaling args-out-of-range in mouse.el * lisp/mouse.el (mouse-posn-property): Avoid signaling args-out-of-range errors when mode-line format uses min-width 'display' property. (Bug#59452) diff --git a/lisp/mouse.el b/lisp/mouse.el index e38a4f8a71..f72ab4fc64 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -1579,6 +1579,7 @@ mouse-posn-property ;; `category' property at PT while doing the (get-char-property ;; pt property w)! (or (and str + (< (cdr str) (length (car str))) (get-text-property (cdr str) property (car str))) ;; Mouse clicks in the fringe come with a position in ;; (nth 5). This is useful but is not exactly where we clicked, so commit 43e616aca56daa438e47051e15f8d2a7454a5cb1 Author: Eli Zaretskii Date: Wed Nov 23 16:54:01 2022 +0200 Improve documentation of locale-specific string comparison * doc/lispref/strings.texi (Text Comparison): * src/fns.c (Fstring_collate_equalp): Improve documentation of 'string-collate-equalp' and 'string-collate-lessp'. (Bug#59275) diff --git a/doc/lispref/strings.texi b/doc/lispref/strings.texi index 4454188cc4..2f277ea73a 100644 --- a/doc/lispref/strings.texi +++ b/doc/lispref/strings.texi @@ -558,11 +558,13 @@ Text Comparison @cindex locale-dependent string equivalence @defun string-collate-equalp string1 string2 &optional locale ignore-case This function returns @code{t} if @var{string1} and @var{string2} are -equal with respect to collation rules. A collation rule is not only +equal with respect to the collation rules of the specified +@var{locale}, which defaults to your current system locale. A +collation rule is not only determined by the lexicographic order of the characters contained in -@var{string1} and @var{string2}, but also further rules about +@var{string1} and @var{string2}, but also by further rules about relations between these characters. Usually, it is defined by the -@var{locale} environment Emacs is running with and by the Standard C +locale environment with which Emacs is running and by the Standard C library against which Emacs was linked@footnote{ For more information about collation rules and their locale dependencies, see @uref{https://unicode.org/reports/tr10/, The Unicode @@ -589,8 +591,12 @@ Text Comparison systems, while it would be, e.g., @code{"enu_USA.1252"} on MS-Windows systems. -If @var{ignore-case} is non-@code{nil}, characters are converted to lower-case -before comparing them. +If @var{ignore-case} is non-@code{nil}, characters are compared +case-insensitively, by converting them to lower-case. However, if the +underlying system library doesn't provide locale-specific collation +rules, this function falls back to @code{string-equal}, in which case +the @var{ignore-case} argument is ignored, and the comparison will +always be case-sensitive. @vindex w32-collate-ignore-punctuation To emulate Unicode-compliant collation on MS-Windows systems, @@ -672,11 +678,13 @@ Text Comparison @cindex locale-dependent string comparison @defun string-collate-lessp string1 string2 &optional locale ignore-case This function returns @code{t} if @var{string1} is less than -@var{string2} in collation order. A collation order is not only +@var{string2} in collation order of the specified @var{locale}, which +defaults to your current system locale. A collation order is not only determined by the lexicographic order of the characters contained in -@var{string1} and @var{string2}, but also further rules about +@var{string1} and @var{string2}, but also by further rules about relations between these characters. Usually, it is defined by the -@var{locale} environment Emacs is running with. +locale environment with which Emacs is running, and by the Standard C +library against which Emacs was linked. For example, punctuation and whitespace characters might be ignored for sorting (@pxref{Sequence Functions}): @@ -706,8 +714,12 @@ Text Comparison @end group @end example -If @var{ignore-case} is non-@code{nil}, characters are converted to lower-case -before comparing them. +If @var{ignore-case} is non-@code{nil}, characters are compared +case-insensitively, by converting them to lower-case. However, if the +underlying system library doesn't provide locale-specific collation +rules, this function falls back to @code{string-lessp}, in which case +the @var{ignore-case} argument is ignored, and the comparison will +always be case-sensitive. To emulate Unicode-compliant collation on MS-Windows systems, bind @code{w32-collate-ignore-punctuation} to a non-@code{nil} value, since diff --git a/src/fns.c b/src/fns.c index e337c0958d..7cc6d00afe 100644 --- a/src/fns.c +++ b/src/fns.c @@ -644,7 +644,8 @@ DEFUN ("string-collate-equalp", Fstring_collate_equalp, Sstring_collate_equalp, the codeset part of the locale cannot be \"UTF-8\" on MS-Windows. If your system does not support a locale environment, this function -behaves like `string-equal'. +behaves like `string-equal', and in that case the IGNORE-CASE argument +is ignored. Do NOT use this function to compare file names for equality. */) (Lisp_Object s1, Lisp_Object s2, Lisp_Object locale, Lisp_Object ignore_case) commit 5568ac2db0fe2707676d9e4d1cfe027fba83767d Author: Eli Zaretskii Date: Wed Nov 23 16:18:55 2022 +0200 Fix error signaled by mouse-highlight on mode line * src/xdisp.c (note_mode_line_or_margin_highlight): Avoid signaling args-out-of-range errors when mode-line format uses min-width 'display' property. (Bug#59452) diff --git a/src/xdisp.c b/src/xdisp.c index b5f013ea6a..5dcf21dc4c 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -34576,8 +34576,11 @@ note_mode_line_or_margin_highlight (Lisp_Object window, int x, int y, } #endif /* HAVE_WINDOW_SYSTEM */ + /* CHARPOS can be beyond the last position of STRING due, e.g., to + min-width 'display' property. Fix that, to let all the calls to + get-text-property below do their thing. */ if (STRINGP (string)) - pos = make_fixnum (charpos); + pos = make_fixnum (min (charpos, SCHARS (string) - 1)); /* Set the help text and mouse pointer. If the mouse is on a part of the mode line without any text (e.g. past the right edge of commit 43060910874f46579fa190d9b5534508e4ea058e Author: Po Lu Date: Wed Nov 23 20:36:39 2022 +0800 Improve last change to xterm.c * src/xfns.c (Fx_display_last_user_time): Reject overly large timestamps. * src/xterm.c (x_display_set_last_user_time, handle_one_xevent): New functions. diff --git a/src/xfns.c b/src/xfns.c index 95092ce05f..fa2c0751d9 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -9728,10 +9728,12 @@ DEFUN ("x-display-set-last-user-time", Fx_display_last_user_time, (Lisp_Object time_object, Lisp_Object terminal) { struct x_display_info *dpyinfo; - Time time; + uint32_t time; + /* time should be a 32-bit integer, regardless of what the size of + the X type `Time' is on this system. */ dpyinfo = check_x_display_info (terminal); - CONS_TO_INTEGER (time_object, Time, time); + CONS_TO_INTEGER (time_object, uint32_t, time); x_set_last_user_time_from_lisp (dpyinfo, time); return Qnil; diff --git a/src/xterm.c b/src/xterm.c index 732fbf462c..cfd8c385d1 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -7749,11 +7749,6 @@ x_display_set_last_user_time (struct x_display_info *dpyinfo, Time time, old_time = dpyinfo->last_user_time; #endif - /* Time can be sign extended if retrieved from a client message. - Make sure it is always 32 bits, or systems with 64-bit longs - will crash after 24 days of X server uptime. (bug#59480) */ - time &= X_ULONG_MAX; - #ifdef ENABLE_CHECKING eassert (time <= X_ULONG_MAX); #endif @@ -18626,7 +18621,12 @@ handle_one_xevent (struct x_display_info *dpyinfo, /* Set the provided time as the user time, which is required for SetInputFocus to work correctly after taking the input focus. */ - x_display_set_last_user_time (dpyinfo, event->xclient.data.l[1], + + /* Time can be sign extended if retrieved from a client message. + Make sure it is always 32 bits, or systems with 64-bit longs + will crash after 24 days of X server uptime. (bug#59480) */ + x_display_set_last_user_time (dpyinfo, (event->xclient.data.l[1] + & 0xffffffff), true, true); goto done; } commit 1524fe427d00c1cf255b9d68cc8565de45ea78df Author: Michael Albinus Date: Wed Nov 23 12:00:35 2022 +0100 Restore tramp-achive's Emacs 26 compatibility * lisp/net/tramp-archive.el (tramp-archive-autoload-file-name-regexp): Special handling of Emacs 26. Simplify the other part. * test/lisp/net/tramp-tests.el (tramp-test48-unload): Special case of `tramp-register-archive-file-name-handler'. diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index 5b2af7c6b2..0a8c574d84 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -183,23 +183,32 @@ tramp-archive-compression-suffixes ;; The definition of `tramp-archive-file-name-regexp' contains calls ;; to `regexp-opt', which cannot be autoloaded while loading ;; loaddefs.el. So we use a macro, which is evaluated only when needed. -;; When tramp-archive.el is unloaded and reloaded, it gripes about -;; missing `tramp-archive{-compression]-suffixes'. We protect this. +;; Emacs 26 and earlier cannot use the autoload form +;; `tramp-compat-rx'. So we refrain from using `rx'. ;;;###autoload (progn (defmacro tramp-archive-autoload-file-name-regexp () "Regular expression matching archive file names." - `(tramp-compat-rx + (if (<= emacs-major-version 26) + '(concat + "\\`" "\\(" ".+" "\\." + ;; Default suffixes ... + (regexp-opt tramp-archive-suffixes) + ;; ... with compression. + "\\(?:" "\\." (regexp-opt tramp-archive-compression-suffixes) "\\)*" + "\\)" ;; \1 + "\\(" "/" ".*" "\\)" "\\'") ;; \2 + `(rx bos ;; This group is used in `tramp-archive-file-name-archive'. (group (+ nonl) ;; Default suffixes ... - "." ,(cons '| (bound-and-true-p tramp-archive-suffixes)) + "." (| ,@tramp-archive-suffixes) ;; ... with compression. - (? "." ,(cons '| (bound-and-true-p tramp-archive-compression-suffixes)))) + (? "." (| ,@tramp-archive-compression-suffixes))) ;; This group is used in `tramp-archive-file-name-localname'. (group "/" (* nonl)) - eos))) + eos)))) (put #'tramp-archive-autoload-file-name-regexp 'tramp-autoload t) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index a5bae46a58..a79c47be72 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -7630,6 +7630,9 @@ tramp-test48-unload (string-prefix-p "tramp" (symbol-name x)) ;; `tramp-completion-mode' is autoloaded in Emacs < 28.1. (not (eq 'tramp-completion-mode x)) + ;; `tramp-register-archive-file-name-handler' is autoloaded + ;; in Emacs < 29.1. + (not (eq 'tramp-register-archive-file-name-handler x)) (not (string-match-p (rx bol "tramp" (? "-archive") (** 1 2 "-") "test") (symbol-name x))) commit 9f4306cd8d086745750769d612df3f71defeea1e Author: Shynur Date: Wed Nov 23 10:26:46 2022 +0100 ; * doc/lispintro/emacs-lisp-intro.texi (Complete kill-region): Fix typo diff --git a/doc/lispintro/emacs-lisp-intro.texi b/doc/lispintro/emacs-lisp-intro.texi index df8fa2f8e7..860ef2fc78 100644 --- a/doc/lispintro/emacs-lisp-intro.texi +++ b/doc/lispintro/emacs-lisp-intro.texi @@ -7981,7 +7981,7 @@ Complete kill-region (progn (message "Read only text copied to kill ring") nil) (barf-if-buffer-read-only) ;; If the buffer isn't read-only, the text is. - (signal 'text-read-only (list (current-buffer))))) + (signal 'text-read-only (list (current-buffer))))))) @end group @end smallexample commit a142841ad1ee36d409d8fe5f6d9fbd5e87879b67 Author: Juri Linkov Date: Wed Nov 23 10:50:23 2022 +0200 * lisp/outline.el: 'S-' on buffer buttons cycles all outlines. (outline--create-button-icons, outline--insert-button): Bind 'S-' to 'outline-cycle-buffer' as it's already done for buttons on the margins. Ignore 'S-'. Don't hard-code 'help-echo' since it should be customizable by the ':help-echo' keyword in 'define-icon'. diff --git a/lisp/outline.el b/lisp/outline.el index 2465a4963a..86ac19aa41 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -1777,7 +1777,12 @@ outline--create-button-icons (propertize (icon-string icon-name) 'mouse-face 'default 'follow-link 'mouse-face - 'keymap (define-keymap "" #'outline-cycle))) + 'keymap (define-keymap + "" #'outline-cycle + ;; Need to override the global binding + ;; `mouse-appearance-menu' with : + "S-" #'ignore + "S-" #'outline-cycle-buffer))) (list 'outline-open (if outline--use-rtl 'outline-close-rtl 'outline-close)))))) @@ -1805,10 +1810,11 @@ outline--insert-button (overlay-put o 'mouse-face 'highlight) (overlay-put o 'keymap (define-keymap "RET" #'outline-cycle - "" #'outline-cycle)) - (overlay-put o 'help-echo (if (eq type 'close) - "Click to show" - "Click to hide"))) + "" #'outline-cycle + ;; Need to override the global binding + ;; `mouse-appearance-menu' with : + "S-" #'ignore + "S-" #'outline-cycle-buffer))) ('in-margins (overlay-put o 'before-string icon) (overlay-put o 'keymap (define-keymap "RET" #'outline-cycle))) commit 3573ebfa6d94411257ffefdf9eb72f508dbe502c Author: Juri Linkov Date: Wed Nov 23 10:38:28 2022 +0200 * lisp/progmodes/xref.el: Support outline-minor-mode (bug#49731) (xref--xref-buffer-mode): Set buffer-local variables outline-minor-mode-cycle, outline-minor-mode-use-buttons, outline-search-function, outline-level as settings for enabling outline-minor-mode in xref output buffers where outline headings are xref groups, and their lines can be hidden by outline commands. diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 89a090ae93..139929dc8a 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -919,6 +919,8 @@ xref--xref-buffer-mode-map (define-key map (kbd "M-,") #'xref-quit-and-pop-marker-stack) map)) +(declare-function outline-search-text-property "outline" (property &optional value bound move backward looking-at)) + (define-derived-mode xref--xref-buffer-mode special-mode "XREF" "Mode for displaying cross-references." (setq buffer-read-only t) @@ -927,7 +929,14 @@ xref--xref-buffer-mode (setq imenu-prev-index-position-function #'xref--imenu-prev-index-position) (setq imenu-extract-index-name-function - #'xref--imenu-extract-index-name)) + #'xref--imenu-extract-index-name) + (setq-local outline-minor-mode-cycle t + outline-minor-mode-use-buttons t + outline-search-function + (lambda (&optional bound move backward looking-at) + (outline-search-text-property + 'xref-group nil bound move backward looking-at)) + outline-level (lambda () 1))) (defvar xref--transient-buffer-mode-map (let ((map (make-sparse-keymap)))