commit 48ecbccaa3244183f58c5140f09b0b8eebdf65c9 (HEAD, refs/remotes/origin/master) Author: Andrew G Cohen Date: Wed Mar 29 14:05:59 2023 +0800 Update gnus/nnselect marks only for current articles * lisp/gnus/nnselect.el (nnselect-push-info): Restrict updating of marked articles to those whose headers have been retrieved, taking care to handle 'tuples. diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el index 4680cf23e5e..9a2957c9f52 100644 --- a/lisp/gnus/nnselect.el +++ b/lisp/gnus/nnselect.el @@ -895,13 +895,17 @@ nnselect-push-info ;; collect the set of marked article lists categorized by ;; originating groups (pcase-dolist (`(,mark . ,type) gnus-article-mark-lists) - (let (type-list) - (when (setq type-list - (symbol-value (intern (format "gnus-newsgroup-%s" mark)))) - (push (cons - type - (numbers-by-group type-list (gnus-article-mark-to-type type))) - mark-list)))) + (let ((mark-type (gnus-article-mark-to-type type)) + (type-list (symbol-value + (intern (format "gnus-newsgroup-%s" mark))))) + (when type-list + (unless (eq 'tuple mark-type) + (setq type-list (range-list-intersection + gnus-newsgroup-articles type-list))) + (push (cons + type + (numbers-by-group type-list mark-type)) + mark-list)))) ;; now work on each originating group one at a time (pcase-dolist (`(,artgroup . ,artlist) (numbers-by-group gnus-newsgroup-articles)) commit 859b94e338639e1838e607be5784dc65ad455671 Author: Andrew G Cohen Date: Wed Mar 29 10:23:06 2023 +0800 Compute gnus/nnselect read articles from summary variables * lisp/gnus/nnselect.el (nnselect-push-info): The current list of read articles should be computed from the summary buffer local variables, not from the group info. diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el index 42247574cc7..4680cf23e5e 100644 --- a/lisp/gnus/nnselect.el +++ b/lisp/gnus/nnselect.el @@ -884,13 +884,14 @@ nnselect-search-thread -(defun nnselect-push-info (group) +(defun nnselect-push-info (_group) "Copy mark-lists from GROUP to the originating groups." (let ((select-unreads (numbers-by-group gnus-newsgroup-unreads)) - (select-reads (numbers-by-group - (gnus-info-read (gnus-get-info group)) 'range)) - (select-unseen (numbers-by-group gnus-newsgroup-unseen)) - (gnus-newsgroup-active nil) mark-list) + (select-reads (numbers-by-group + (gnus-sorted-difference gnus-newsgroup-articles + gnus-newsgroup-unreads))) + (select-unseen (numbers-by-group gnus-newsgroup-unseen)) + (gnus-newsgroup-active nil) mark-list) ;; collect the set of marked article lists categorized by ;; originating groups (pcase-dolist (`(,mark . ,type) gnus-article-mark-lists) commit a371be52576e1f14787a7699582d2f31af7b05c7 Author: Andrew G Cohen Date: Tue Mar 28 20:23:34 2023 +0800 Don't modify gnus group info when gnus-newsgroup-selection is nil * lisp/gnus/nnselect.el (nnselect-push-info): Don't try to propagate info to component groups if gnus-newsgroup-selection is nil. * lisp/gnus/nnselect.el (nnselect-request-update-info): Don't update the nnselect group info if gnus-newsgroup-selection is nil. diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el index 7d8d28ac431..42247574cc7 100644 --- a/lisp/gnus/nnselect.el +++ b/lisp/gnus/nnselect.el @@ -594,62 +594,63 @@ nnselect-request-update-info (gnus-newsgroup-selection (or gnus-newsgroup-selection (nnselect-get-artlist group))) newmarks) - (gnus-info-set-marks info nil) - (setf (gnus-info-read info) nil) - (pcase-dolist (`(,artgroup . ,nartids) - (ids-by-group - (number-sequence 1 (nnselect-artlist-length - gnus-newsgroup-selection)))) - (let* ((gnus-newsgroup-active nil) - (idmap (make-hash-table :test 'eql)) - (gactive (sort (mapcar 'cdr nartids) '<)) - (group-info (gnus-get-info artgroup)) - (marks (gnus-info-marks group-info))) - (pcase-dolist (`(,val . ,key) nartids) - (puthash key val idmap)) - (setf (gnus-info-read info) - (range-add-list - (gnus-info-read info) - (sort (mapcar (lambda (art) (gethash art idmap)) - (gnus-sorted-intersection - gactive - (range-uncompress (gnus-info-read group-info)))) - '<))) - (pcase-dolist (`(,type . ,mark-list) marks) - (let ((mark-type (gnus-article-mark-to-type type)) new) - (when - (setq new - (if (not mark-list) nil - (cond - ((eq mark-type 'tuple) - (delq nil - (mapcar - (lambda (mark) - (let ((id (gethash (car mark) idmap))) - (when id (cons id (cdr mark))))) - mark-list))) - (t - (mapcar (lambda (art) (gethash art idmap)) - (gnus-sorted-intersection - gactive (range-uncompress mark-list))))))) - (let ((previous (alist-get type newmarks))) - (if previous - (nconc previous new) - (push (cons type new) newmarks)))))))) - - ;; Clean up the marks: compress lists; - (pcase-dolist (`(,type . ,mark-list) newmarks) - (let ((mark-type (gnus-article-mark-to-type type))) - (unless (eq mark-type 'tuple) - (setf (alist-get type newmarks) - (gnus-compress-sequence (sort mark-list '<)))))) - ;; and ensure an unexist key. - (unless (assq 'unexist newmarks) - (push (cons 'unexist nil) newmarks)) - - (gnus-info-set-marks info newmarks) - (gnus-set-active group (cons 1 (nnselect-artlist-length - gnus-newsgroup-selection))))) + (when gnus-newsgroup-selection + (gnus-info-set-marks info nil) + (setf (gnus-info-read info) nil) + (pcase-dolist (`(,artgroup . ,nartids) + (ids-by-group + (number-sequence 1 (nnselect-artlist-length + gnus-newsgroup-selection)))) + (let* ((gnus-newsgroup-active nil) + (idmap (make-hash-table :test 'eql)) + (gactive (sort (mapcar 'cdr nartids) #'<)) + (group-info (gnus-get-info artgroup)) + (marks (gnus-info-marks group-info))) + (pcase-dolist (`(,val . ,key) nartids) + (puthash key val idmap)) + (setf (gnus-info-read info) + (range-add-list + (gnus-info-read info) + (sort (mapcar (lambda (art) (gethash art idmap)) + (gnus-sorted-intersection + gactive + (range-uncompress (gnus-info-read group-info)))) + #'<))) + (pcase-dolist (`(,type . ,mark-list) marks) + (let ((mark-type (gnus-article-mark-to-type type)) new) + (when + (setq new + (if (not mark-list) nil + (cond + ((eq mark-type 'tuple) + (delq nil + (mapcar + (lambda (mark) + (let ((id (gethash (car mark) idmap))) + (when id (cons id (cdr mark))))) + mark-list))) + (t + (mapcar (lambda (art) (gethash art idmap)) + (gnus-sorted-intersection + gactive (range-uncompress mark-list))))))) + (let ((previous (alist-get type newmarks))) + (if previous + (nconc previous new) + (push (cons type new) newmarks)))))))) + + ;; Clean up the marks: compress lists; + (pcase-dolist (`(,type . ,mark-list) newmarks) + (let ((mark-type (gnus-article-mark-to-type type))) + (unless (eq mark-type 'tuple) + (setf (alist-get type newmarks) + (gnus-compress-sequence (sort mark-list #'<)))))) + ;; and ensure an unexist key. + (unless (assq 'unexist newmarks) + (push (cons 'unexist nil) newmarks)) + + (gnus-info-set-marks info newmarks) + (gnus-set-active group (cons 1 (nnselect-artlist-length + gnus-newsgroup-selection)))))) (deffoo nnselect-request-thread (header &optional group server) @@ -759,7 +760,8 @@ nnselect-request-thread (deffoo nnselect-close-group (group &optional _server) (let ((group (nnselect-add-prefix group))) (unless gnus-group-is-exiting-without-update-p - (nnselect-push-info group)) + (when gnus-newsgroup-selection + (nnselect-push-info group))) (setq gnus-newsgroup-selection nil) (when (gnus-ephemeral-group-p group) (gnus-kill-ephemeral-group group) commit 9545869aac7c0b2af614fbf5116409192655a4c6 Author: Andrew G Cohen Date: Mon Mar 27 09:37:55 2023 +0800 Keep the gnus active range current while getting articles * lisp/gnus/gnus-group.el (gnus-group-get-new-news-this-group): * lisp/gnus/gnus-group.el (gnus-get-unread-articles-in-group): Update the current value of the active range since it might have changed. diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 070d1223e2c..8c1d7e3c86a 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -4195,7 +4195,8 @@ gnus-group-get-new-news-this-group (let ((info (gnus-get-info group)) (active (gnus-active group))) (when info - (gnus-request-update-info info method)) + (gnus-request-update-info info method) + (setq active (gnus-active group))) (gnus-get-unread-articles-in-group info active) (unless (gnus-virtual-group-p group) (gnus-close-group group)) diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index d59b5b58ceb..19b8b09de03 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -1490,7 +1490,8 @@ gnus-get-unread-articles-in-group (gnus-request-update-info info (inline (gnus-find-method-for-group (gnus-info-group info))))) - (gnus-activate-group (gnus-info-group info) nil t)) + (gnus-activate-group (gnus-info-group info) nil t) + (setq active (gnus-active (gnus-info-group info)))) (let* ((range (gnus-info-read info)) (num 0)) commit cf7860c38398c5d7d76e8859273eae5a7a33c57e Author: Andrew G Cohen Date: Tue Mar 28 20:21:13 2023 +0800 * lisp/gnus/nnselect.el (nnselect-request-article): Check car of thread diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el index 66577282a0f..7d8d28ac431 100644 --- a/lisp/gnus/nnselect.el +++ b/lisp/gnus/nnselect.el @@ -440,7 +440,7 @@ nnselect-request-article (if (eq 'nnselect (car (gnus-server-to-method server))) (with-current-buffer gnus-summary-buffer (let ((thread (gnus-id-to-thread article))) - (when thread + (when (car thread) (mapc (lambda (x) (when (and x (> x 0)) commit b26ccf488ef9a784c418245b7b01cb349af85006 Author: Spencer Baugh Date: Sun Apr 9 04:50:20 2023 +0300 project.el: Use project-name to calculate prefixed buffer name * lisp/progmodes/project.el (project-prefixed-buffer-name): Use project-name to calculate prefixed buffer name (bug#62548). (project-compilation-buffer-name-function): Update doc. diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 11228226592..877d79353aa 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -1248,8 +1248,10 @@ compilation-read-command (defun project-prefixed-buffer-name (mode) (concat "*" - (file-name-nondirectory - (directory-file-name default-directory)) + (if-let ((proj (project-current nil))) + (project-name proj) + (file-name-nondirectory + (directory-file-name default-directory))) "-" (downcase mode) "*")) @@ -1261,7 +1263,7 @@ project-compilation-buffer-name-function :version "28.1" :group 'project :type '(choice (const :tag "Default" nil) - (const :tag "Prefixed with root directory name" + (const :tag "Prefixed with project name" project-prefixed-buffer-name) (function :tag "Custom function"))) commit e33c0a549153fa3894f3b5e9c5e42ce07a1a68c7 Author: João Távora Date: Sat Apr 8 23:26:43 2023 +0100 Eglot: more work on eglot--sig-info (bug#62687) Simplify function and now also consider individual parameter documentation strings, which typescript-language-server seems to provide. * lisp/progmodes/eglot.el (eglot--sig-info): Rework. diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index b10344a706b..3f00281e155 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -3118,44 +3118,55 @@ eglot--hover-info (mapconcat #'eglot--format-markup (if (vectorp contents) contents (list contents)) "\n")) -(defun eglot--sig-info (sig &optional sig-help-active-param briefp) - (eglot--dbind ((SignatureInformation) label documentation parameters activeParameter) +(defun eglot--sig-info (sig &optional sig-active briefp) + (eglot--dbind ((SignatureInformation) + ((:label siglabel)) + ((:documentation sigdoc)) parameters activeParameter) sig (with-temp-buffer - (save-excursion (insert label)) - (let ((active-param (or activeParameter sig-help-active-param)) - (labeldoc (and (not briefp) documentation - (eglot--format-markup documentation))) - params-start params-end) - ;; Ad-hoc attempt to parse label as () + (save-excursion (insert siglabel)) + ;; Ad-hoc attempt to parse label as () (when (looking-at "\\([^(]*\\)(\\([^)]+\\))") - (setq params-start (match-beginning 2) params-end (match-end 2)) (add-face-text-property (match-beginning 1) (match-end 1) 'font-lock-function-name-face)) ;; Add documentation, indented so we can distinguish multiple signatures - (when labeldoc + (when-let (doc (and (not briefp) sigdoc (eglot--format-markup sigdoc))) (goto-char (point-max)) - (insert "\n" (replace-regexp-in-string "^" " " labeldoc))) - ;; Decide what to do with the active parameter... - (when (and active-param (< -1 active-param (length parameters))) - (eglot--dbind ((ParameterInformation) label) - (aref parameters active-param) - ;; ...perhaps highlight it in the formals list - (when params-start - (goto-char params-start) - (pcase-let - ((`(,beg ,end) - (if (stringp label) - (let ((case-fold-search nil)) - (and (re-search-forward - (concat "\\<" (regexp-quote label) "\\>") - params-end t) - (list (match-beginning 0) (match-end 0)))) - (mapcar #'1+ (append label nil))))) - (if (and beg end) - (add-face-text-property - beg end - 'eldoc-highlight-function-argument))))))) + (insert "\n" (replace-regexp-in-string "^" " " doc))) + ;; Now to the parameters + (cl-loop + with active-param = (or sig-active activeParameter) + for i from 0 for parameter across parameters do + (eglot--dbind ((ParameterInformation) + ((:label parlabel)) + ((:documentation pardoc))) + parameter + ;; ...perhaps highlight it in the formals list + (when (and (eq i active-param)) + (save-excursion + (goto-char (point-min)) + (pcase-let + ((`(,beg ,end) + (if (stringp parlabel) + (let ((case-fold-search nil)) + (and (search-forward parlabel (line-end-position) t) + (list (match-beginning 0) (match-end 0)))) + (mapcar #'1+ (append parlabel nil))))) + (if (and beg end) + (add-face-text-property + beg end + 'eldoc-highlight-function-argument))))) + ;; ...and/or maybe add its doc on a line by its own. + (let (fpardoc) + (when (and pardoc (not briefp) + (not (string-empty-p + (setq fpardoc (eglot--format-markup pardoc))))) + (insert "\n " + (propertize + (if (stringp parlabel) parlabel + (apply #'substring siglabel (mapcar #'1+ parlabel))) + 'face (and (eq i active-param) 'eldoc-highlight-function-argument)) + ": " fpardoc))))) (buffer-string)))) (defun eglot-signature-eldoc-function (cb) @@ -3167,7 +3178,7 @@ eglot-signature-eldoc-function :textDocument/signatureHelp (eglot--TextDocumentPositionParams) :success-fn (eglot--lambda ((SignatureHelp) - signatures activeSignature activeParameter) + signatures activeSignature (activeParameter 0)) (eglot--when-buffer-window buf (let ((active-sig (and (cl-plusp (length signatures)) (aref signatures (or activeSignature 0))))) commit 52c8d5371e4649d3dec4d254dcc483f8dee6b49c Author: F. Jason Park Date: Fri Dec 9 22:00:59 2022 -0800 * etc/ERC-NEWS: Add section for ERC 5.6. diff --git a/etc/ERC-NEWS b/etc/ERC-NEWS index 434bfab94e9..8f1b89f268b 100644 --- a/etc/ERC-NEWS +++ b/etc/ERC-NEWS @@ -11,6 +11,183 @@ This file is about changes in ERC, the powerful, modular, and extensible IRC (Internet Relay Chat) client distributed with GNU Emacs since Emacs version 22.1. + +* Changes in ERC 5.6 + +** Module 'keep-place' now offers a visual indicator. +Remember your place in ERC buffers a bit more easily while retaining +the freedom to look around. Optionally sync the indicator to any +progress made when you haven't yet caught up to the live stream. See +options 'erc-keep-place-indicator-style' and friends and new module +'keep-place-indicator', which for now must be added manually to +'erc-modules'. + +** Module 'fill' now offers a style based on 'visual-line-mode'. +This fill style mimics the "hanging indent" look of 'erc-fill-static' +and provides some movement and editing commands to optionally tame the +less familiar aspects of 'visual-line' behavior. An interactive +helper called 'erc-fill-wrap-nudge' allows for dynamic "refilling" of +buffers on the fly. Set 'erc-fill-function' to 'erc-fill-wrap' to get +started. + +** A unified interactive entry point. +New users are often dismayed to discover that M-x ERC doesn't connect +to its default network, Libera.Chat, over TLS. Though perhaps a +decade overdue, this is no longer the case. Other UX improvements in +this area aim to make the process of connecting interactively slightly +more streamlined and less repetitive, even for veteran users. + +** New buffer-display option 'erc-interactive-display'. +A point of friction for new users and one only just introduced with +ERC 5.5 has been the lack of visual feedback when first connecting via +M-x erc. As explained below in the news for 5.5, the discovery of a +security issue led to new ERC buffers being "buried" on creation. On +further reflection, this was judged to have been an overcorrection in +the case of interactive invocations, hence the new option +'erc-interactive-display', which is set to 'buffer' (i.e., "take me +there") by default. Accompanying this addition are "display"-suffixed +aliases for related options 'erc-join-buffer' and 'erc-auto-query', +which users have reported as being difficult to discover and remember. + +** Setting a module's mode variable via Customize earns a warning. +Trying and failing to activate a module via its minor mode's Custom +widget has been an age-old annoyance for new users. Previously +ineffective, this method now actually works, but it also admonishes +users to edit the 'erc-modules' widget instead. + +** The option 'erc-timestamp-use-align-to' is more versatile. +While this option has always offered to right-align stamps via the +'display' text property, it's now more effective at doing so when set +to a number indicating an offset from the right edge. And when set to +the symbol 'margin', it displays stamps in the right margin, although, +at the moment, this is mostly intended for use by other modules, such +as 'fill-wrap', described above. For both these variants, users of +the 'log' module may want to customize 'erc-log-filter-function' to +'erc-stamp-prefix-log-filter' to avoid ragged right-hand stamps +appearing in their saved logs. + +** Smarter reconnect handling for users on the move. +ERC now offers a new, experimental reconnect strategy in the function +'erc-server-delayed-check-reconnect', which tests for underlying +connectivity before attempting to reconnect in earnest. See options +'erc-server-reconnect-function' and 'erc-nickname-in-use-functions' to +get started. + +** Easily constrain all ERC-related business to a dedicated frame. +The option 'erc-reuse-frames' can now be set to 'displayed', which +tells ERC to show new buffers in frames already occupied by buffers +from the same connection. This customization depends on the option +'erc-buffer-display' (formerly 'erc-join-buffer') being set to +'frame'. If you find the name 'displayed' unhelpful, please suggest +an alternative by writing to the mailing list. + +** Some keybindings are now set by modules rather than their libraries. +To put it another way, simply loading a built-in module's library no +longer modifies 'erc-mode-map'. Instead, modifications occur during +module setup. This should not impact most user configs since ERC +doesn't bother with keys already taken and only removes bindings it's +previously created. Note that while all affected bindings still +reside in 'erc-mode-map', future built-in modules will use their own +minor-mode maps, and new third-party modules should do the same. + +** The option 'erc-timestamp-format-right' has been deprecated. +Having to account for this option prevented other ERC modules from +easily determining what right-hand stamps would look like before +insertion, which is knowledge needed for certain UI decisions. The +way ERC has chosen to address this is imperfect and boils down to +asking users who've customized this option to switch to +'erc-timestamp-format' instead. If you're affected by this and feel +that some other solution, like automatic migration, is justified, +please make that known on the bug list. + +** The 'nicknames' entry in 'erc-button-alist' is officially exceptional. +It's no secret that the 'buttons' module treats potential nicknames +specially. To simplify ERC's move to next-gen "rich UI" extensions, +this special treatment is being canonized. From now on, all values +other than the symbol 'erc-button-buttonize-nicks' appearing in the +"FORM" field (third element) of this entry are considered deprecated +and will incur a warning. + +** Miscellaneous UX changes. +Some minor quality-of-life niceties have finally made their way to +ERC. For example, the function 'erc-echo-timestamp' is now +interactive and can be invoked on any message to view its timestamp in +the echo area. Also, the 'irccontrols' module now supports additional +colors and special handling for "spoilers" (hidden text). And issuing +an "/MOTD" now dispatches a purpose-built command handler. + +** Changes in the library API. + +*** Some top-level dependencies have been removed. +The library 'erc-goodies' is no longer loaded by ERC's main library. +This was done to further cement the move toward a unidirectional +dependency flow begun in 5.5. Additionally, a few barely used and +newly introduced dependencies are now lazily loaded, which may upset +some third-party code. The first of these is 'pp' because its +'pp-to-string' is autoloaded in all supported ERC versions. Also gone +are 'thingatpt', 'time-date', and 'iso8601'. All were used ultra +sparingly, and the latter two have only been around for one minor +release cycle, so their removal hopefully won't cause much churn. + +*** Some ERC-applied text properties have changed. +Chiefly, 'rear-sticky' has been replaced by 'erc-command', which +records the IRC command (or numeric) associated with a message. Less +impactfully, the value of the 'field' property for ERC's prompt has +changed from 't' to the more useful 'erc-prompt', although the +property of the same name has been retained. + +*** ERC now manages timestamp-related properties a bit differently. +For starters, the 'cursor-sensor-functions' property no longer +contains unique closures and thus no longer proves effective for +traversing messages. To compensate, a new property, 'erc-timestamp', +now spans message bodies but not the newlines delimiting them. +Somewhat relatedly, the function 'erc-insert-aligned' has been +deprecated and removed from the primary client code path. + +*** The role of a module's Custom group is now more clearly defined. +Associating built-in modules with Custom groups and provided library +features has improved. More specifically, a module's group now enjoys +the singular purpose of determining where the module's minor mode +variable lives in the Customize interface. And although ERC is now +slightly more adept at linking these entities, third-parties are still +encouraged to keep a module's name aligned with its group's as well as +the provided feature of its containing library, if only for the usual +reasons of namespace hygiene and discoverability. + +*** ERC now supports arbitrary CHANTYPES. +Specifically, channels can be prefixed with any predesignated +character, mainly to afford more flexibility to specialty services, +like bridges to other protocols. + +*** 'erc-cmd-HELP' recognizes subcommands. +Some IRC "slash" commands are hierarchical and require users to +specify a subcommand to actually carry out anything of consequence. +Built-in modules can now provide more detailed help for a particular +subcommand by telling ERC to defer to a specialized handler. + +*** Longtime quasi modules have been made proper. +The 'fill' module is now defined by 'define-erc-module'. The same +goes for ERC's imenu integration, which has 'imenu' now appearing in +the default value of 'erc-modules'. + +*** ERC's prompt survives the insertion of user input and messages. +Previously, ERC's prompt and its input marker disappeared while +running hooks during message insertion, and the position of its +"insert marker" (ERC's per-buffer process mark) was inconsistent +during these spells. To make insertion handling more predictable in +preparation for incorporating various protocol extensions, the prompt +and its bounding markers have become perennial fixtures. In rare +cases, these changes may mean third-party code needs tweaking, for +example, requiring the use of 'insert-before-markers' instead of +'insert'. As always, users feeling unduly inconvenienced by these +changes are encouraged to voice their concerns on the bug list. + +*** Miscellaneous changes +For autoloading purposes, 'Info-goto-node' has been supplanted by +plain old 'info' in 'erc-button-alist', and two helper macros from GNU +ELPA's Compat library are now available to third-party modules as +'erc-compat-call' and 'erc-compat-function'. + * Changes in ERC 5.5 commit 0e4c07dc7448aafd2aa5f6e101d7b7aac23d8a6b Author: F. Jason Park Date: Sat May 21 03:04:04 2022 -0700 Allow erc-reuse-frames to favor connections * lisp/erc/erc.el (erc-reuse-frames): Add alternate value to favor existing frames already displaying buffers from the same connection. (erc--setup-buffer-first-window, erc--display-buffer-use-some-frame): Add helpers to support 'display' variant of `erc-resuse-frames' * test/lisp/erc/erc-tests.el (erc-tests--run-in-term, erc-tests--servars, erc-reuse-frames, erc-tests--erc-reuse-frames, erc-tests--erc-reuse-frames--t, erc-resuse-frames--t, erc-tests--erc-reuse-frames--displayed-single, erc-reuse-frames--displayed-single, erc-tests--assert-server-split, erc-tests--erc-reuse-frames--displayed-double, erc-reuse-frames--displayed-double, erc-tests--erc-reuse-frames--displayed-full, erc-reuse-frames--displayed-full): Add test case and supporting fixtures. (Bug#55540.) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 5aa460241cd..284990e2d43 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -1573,11 +1573,23 @@ erc-frame-dedicated-flag (defcustom erc-reuse-frames t "Determines whether new frames are always created. -Non-nil means that a new frame is not created to display an ERC -buffer if there is already a window displaying it. This only has -effect when `erc-join-buffer' is set to `frame'." + +A value of t means only create a frame for undisplayed buffers. +`displayed' means use any existing, potentially hidden frame +already displaying a buffer from the same network context or, +failing that, a frame showing any ERC buffer. As a last resort, +`displayed' defaults to the selected frame, except for brand new +connections, for which the invoking frame is always used. When +this option is nil, a new frame is always created. + +Regardless of its value, this option is ignored unless +`erc-join-buffer' is set to `frame'. And like most options in +the `erc-buffer' customize group, this has no effect on server +buffers while reconnecting because those are always buried." + :package-version '(ERC . "5.6") ; FIXME sync on release :group 'erc-buffers - :type 'boolean) + :type '(choice boolean + (const displayed))) (defun erc-channel-p (channel) "Return non-nil if CHANNEL seems to be an IRC channel name." @@ -2003,6 +2015,35 @@ erc--update-modules (push mode local-modes)) (error "`%s' is not a known ERC module" module))))) +(defun erc--setup-buffer-first-window (frame a b) + (catch 'found + (walk-window-tree + (lambda (w) + (when (cond ((functionp a) (with-current-buffer (window-buffer w) + (funcall a b))) + (t (eq (buffer-local-value a (window-buffer w)) b))) + (throw 'found t))) + frame nil 0))) + +(defun erc--display-buffer-use-some-frame (buffer alist) + "Maybe display BUFFER in an existing frame for the same connection. +If performed, return window used; otherwise, return nil. Forward ALIST +to display-buffer machinery." + (when-let* + ((idp (lambda (value) + (and erc-networks--id + (erc-networks--id-equal-p erc-networks--id value)))) + (procp (lambda (frame) + (erc--setup-buffer-first-window frame idp erc-networks--id))) + (ercp (lambda (frame) + (erc--setup-buffer-first-window frame 'major-mode 'erc-mode))) + ((or (cdr (frame-list)) (funcall ercp (selected-frame))))) + ;; Workaround to avoid calling `window--display-buffer' directly + (or (display-buffer-use-some-frame buffer + `((frame-predicate . ,procp) ,@alist)) + (display-buffer-use-some-frame buffer + `((frame-predicate . ,ercp) ,@alist))))) + (defun erc-setup-buffer (buffer) "Consults `erc-join-buffer' to find out how to display `BUFFER'." (pcase (if (zerop (erc-with-server-buffer @@ -2018,15 +2059,21 @@ erc-setup-buffer ('bury nil) ('frame - (when (or (not erc-reuse-frames) - (not (get-buffer-window buffer t))) + (cond + ((and (eq erc-reuse-frames 'displayed) + (not (get-buffer-window buffer t))) + (display-buffer buffer '((erc--display-buffer-use-some-frame) + (inhibit-switch-frame . t) + (inhibit-same-window . t)))) + ((or (not erc-reuse-frames) + (not (get-buffer-window buffer t))) (let ((frame (make-frame (or erc-frame-alist default-frame-alist)))) (raise-frame frame) (select-frame frame)) (switch-to-buffer buffer) (when erc-frame-dedicated-flag - (set-window-dedicated-p (selected-window) t)))) + (set-window-dedicated-p (selected-window) t))))) (_ (if (active-minibuffer-window) (display-buffer buffer) diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index 43a5b54dcc7..29bda7e742d 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -399,6 +399,309 @@ erc--switch-to-buffer (dolist (b '("server" "other" "#chan" "#foo" "#fake")) (kill-buffer b)))) +(defun erc-tests--run-in-term (&optional debug) + (let* ((default-directory (getenv "EMACS_TEST_DIRECTORY")) + (emacs (expand-file-name invocation-name invocation-directory)) + (process-environment (cons "ERC_TESTS_SUBPROCESS=1" + process-environment)) + (name (ert-test-name (ert-running-test))) + (temp-file (make-temp-file "erc-term-test-")) + (cmd `(let ((stats 1)) + (setq enable-dir-local-variables nil) + (unwind-protect + (setq stats (ert-run-tests-batch ',name)) + (unless ',debug + (let ((buf (with-current-buffer (messages-buffer) + (buffer-string)))) + (with-temp-file ,temp-file + (insert buf))) + (kill-emacs (ert-stats-completed-unexpected stats)))))) + ;; `ert-test' object in Emacs 29 has a `file-name' field + (file-name (symbol-file name 'ert--test)) + (default-directory (expand-file-name (file-name-directory file-name))) + (package (if-let* ((found (getenv "ERC_PACKAGE_NAME")) + ((string-prefix-p "erc-" found))) + (intern found) + 'erc)) + (setup (and (featurep 'compat) + `(progn + (require 'package) + (let ((package-load-list '((compat t) (,package t)))) + (package-initialize))))) + ;; Make subprocess terminal bigger than controlling. + (buf (cl-letf (((symbol-function 'window-screen-lines) + (lambda () 20)) + ((symbol-function 'window-max-chars-per-line) + (lambda () 40))) + (make-term (symbol-name name) emacs nil "-Q" "-nw" + "-eval" (prin1-to-string setup) + "-l" file-name "-eval" (format "%S" cmd)))) + (proc (get-buffer-process buf)) + (err (lambda () + (with-temp-buffer + (insert-file-contents temp-file) + (message "Subprocess: %s" (buffer-string)) + (delete-file temp-file))))) + (with-current-buffer buf + (set-process-query-on-exit-flag proc nil) + (with-timeout (10 (funcall err) (error "Timed out awaiting result")) + (while (process-live-p proc) + (accept-process-output proc 0.1))) + (while (accept-process-output proc)) + (goto-char (point-min)) + ;; Otherwise gives process exited abnormally with exit-code >0 + (unless (search-forward (format "Process %s finished" name) nil t) + (funcall err) + (ert-fail (when (search-forward "exited" nil t) + (buffer-substring-no-properties (line-beginning-position) + (line-end-position))))) + (delete-file temp-file) + (when noninteractive + (kill-buffer))))) + +(defun erc-tests--servars (source &rest vars) + (unless (bufferp source) + (setq source (get-buffer source))) + (dolist (var vars) + (should (local-variable-if-set-p var)) + (set var (buffer-local-value var source)))) + +(defun erc-tests--erc-reuse-frames (test &optional debug) + (if (and (or debug noninteractive) (not (getenv "ERC_TESTS_SUBPROCESS"))) + (progn + (when (memq system-type '(windows-nt ms-dos)) + (ert-skip "System must be UNIX")) + (erc-tests--run-in-term debug)) + (should-not erc-frame-dedicated-flag) + (should (eq erc-reuse-frames t)) + (let ((erc-join-buffer 'frame) + (erc-reuse-frames t) + (erc-frame-alist nil) + (orig-frame (selected-frame)) + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + (delete-other-frames) + (delete-other-windows) + (set-window-buffer (selected-window) "*scratch*") + (funcall test orig-frame) + (delete-other-frames orig-frame) + (delete-other-windows)))) + +;; TODO add cases for frame-display behavior while reconnecting + +(defun erc-tests--erc-reuse-frames--t (_) + (ert-info ("New server buffer creates and raises second frame") + (with-current-buffer (generate-new-buffer "server") + (erc-mode) + (setq erc-server-process (start-process "server" + (current-buffer) "sleep" "10") + erc-frame-alist (cons '(name . "server") default-frame-alist) + erc-network 'foonet + erc-networks--id (erc-networks--id-create nil) + erc--server-last-reconnect-count 0) + (set-process-buffer erc-server-process (current-buffer)) + (set-process-query-on-exit-flag erc-server-process nil) + (should-not (get-buffer-window (current-buffer) t)) + (erc-setup-buffer (current-buffer)) + (should (equal "server" (frame-parameter (window-frame) 'name))) + (should (get-buffer-window (current-buffer) t)))) + + (ert-info ("New channel creates and raises third frame") + (with-current-buffer (generate-new-buffer "#chan") + (erc-mode) + (erc-tests--servars "server" 'erc-server-process 'erc-networks--id + 'erc-network) + (setq erc-frame-alist (cons '(name . "#chan") default-frame-alist) + erc-default-recipients '("#chan")) + (should-not (get-buffer-window (current-buffer) t)) + (erc-setup-buffer (current-buffer)) + (should (equal "#chan" (frame-parameter (window-frame) 'name))) + (should (get-buffer-window (current-buffer) t)) + (should (cddr (frame-list)))))) + +(ert-deftest erc-reuse-frames--t () + :tags '(:unstable :expensive-test) + (erc-tests--erc-reuse-frames + (lambda (orig-frame) + (erc-tests--erc-reuse-frames--t orig-frame) + (dolist (b '("server" "#chan")) + (kill-buffer b))))) + +(defun erc-tests--erc-reuse-frames--displayed-single (_ server-name chan-name) + + (should (eq erc-reuse-frames 'displayed)) + + (ert-info ("New server buffer shown in existing frame") + (with-current-buffer (generate-new-buffer server-name) + (erc-mode) + (setq erc-server-process (start-process server-name (current-buffer) + "sleep" "10") + erc-frame-alist (cons `(name . ,server-name) default-frame-alist) + erc-network (make-symbol server-name) + erc-server-current-nick "tester" + erc-networks--id (erc-networks--id-create nil) + erc--server-last-reconnect-count 0) + (set-process-buffer erc-server-process (current-buffer)) + (set-process-query-on-exit-flag erc-server-process nil) + (should-not (get-buffer-window (current-buffer) t)) + (erc-setup-buffer (current-buffer)) + (should-not (equal server-name (frame-parameter (window-frame) 'name))) + ;; New server buffer window appears in split below ERT/scratch + (should (get-buffer-window (current-buffer) t)))) + + (ert-info ("New channel shown in existing frame") + (with-current-buffer (generate-new-buffer chan-name) + (erc-mode) + (erc-tests--servars server-name 'erc-server-process 'erc-networks--id + 'erc-network) + (setq erc-frame-alist (cons `(name . ,chan-name) default-frame-alist) + erc-default-recipients (list chan-name)) + (should-not (get-buffer-window (current-buffer) t)) + (erc-setup-buffer (current-buffer)) + (should-not (equal chan-name (frame-parameter (window-frame) 'name))) + ;; New channel buffer replaces server in lower window + (should (get-buffer-window (current-buffer) t)) + (should-not (get-buffer-window server-name t))))) + +(ert-deftest erc-reuse-frames--displayed-single () + :tags '(:unstable :expensive-test) + (erc-tests--erc-reuse-frames + (lambda (orig-frame) + (let ((erc-reuse-frames 'displayed)) + (erc-tests--erc-reuse-frames--displayed-single orig-frame + "server" "#chan") + (should-not (cdr (frame-list)))) + (dolist (b '("server" "#chan")) + (kill-buffer b))))) + +(defun erc-tests--assert-server-split (buffer-or-name frame-name) + ;; Assert current buffer resides on one side of a horizontal split + ;; in the "server" frame but is not selected. + (let* ((buffer-window (get-buffer-window buffer-or-name t)) + (buffer-frame (window-frame buffer-window))) + (should (equal frame-name (frame-parameter buffer-frame 'name))) + (should (memq buffer-window (car-safe (window-tree buffer-frame)))) + (should-not (eq buffer-window (frame-selected-window))) + buffer-frame)) + +(defun erc-tests--erc-reuse-frames--displayed-double (_) + (should (eq erc-reuse-frames 'displayed)) + + (make-frame '((name . "other"))) + (select-frame (make-frame '((name . "server"))) 'no-record) + (set-window-buffer (selected-window) "*scratch*") ; invokes `erc' + + ;; A user invokes an entry point and switches immediately to a new + ;; frame before autojoin kicks in (bug#55540). + + (ert-info ("New server buffer shown in selected frame") + (with-current-buffer (generate-new-buffer "server") + (erc-mode) + (setq erc-server-process (start-process "server" (current-buffer) + "sleep" "10") + erc-network 'foonet + erc-server-current-nick "tester" + erc-networks--id (erc-networks--id-create nil) + erc--server-last-reconnect-count 0) + (set-process-buffer erc-server-process (current-buffer)) + (set-process-query-on-exit-flag erc-server-process nil) + (should-not (get-buffer-window (current-buffer) t)) + (erc-setup-buffer (current-buffer)) + (should (equal "server" (frame-parameter (window-frame) 'name))) + (should (get-buffer-window (current-buffer) t)))) + + (select-frame-by-name "other") + + (ert-info ("New channel shown in dedicated frame") + (with-current-buffer (generate-new-buffer "#chan") + (erc-mode) + (erc-tests--servars "server" 'erc-server-process 'erc-networks--id + 'erc-network) + (setq erc-frame-alist (cons '(name . "#chan") default-frame-alist) + erc-default-recipients '("#chan")) + (should-not (get-buffer-window (current-buffer) t)) + (erc-setup-buffer (current-buffer)) + (erc-tests--assert-server-split (current-buffer) "server") + ;; New channel buffer replaces server in lower window of other frame + (should-not (get-buffer-window "server" t))))) + +(ert-deftest erc-reuse-frames--displayed-double () + :tags '(:unstable :expensive-test) + (erc-tests--erc-reuse-frames + (lambda (orig-frame) + (let ((erc-reuse-frames 'displayed)) + (erc-tests--erc-reuse-frames--displayed-double orig-frame)) + (dolist (b '("server" "#chan")) + (kill-buffer b))))) + +;; If a frame showing ERC buffers exists among other frames, new, +;; additional connections will use the existing IRC frame. However, +;; if two or more frames exist with ERC buffers unique to a particular +;; connection, the correct frame will be found. + +(defun erc-tests--erc-reuse-frames--displayed-full (orig-frame) + (erc-tests--erc-reuse-frames--displayed-double orig-frame) + ;; Server buffer is not displayed because #chan has replaced it in + ;; the "server" frame, which is not selected. + (should (equal "other" (frame-parameter (window-frame) 'name))) + (erc-tests--erc-reuse-frames--displayed-single orig-frame "ircd" "#spam") + (should (equal "other" (frame-parameter (window-frame) 'name))) + + ;; Buffer "#spam" has replaced "ircd", which earlier replaced + ;; "#chan" in frame "server". But this is confusing, so... + (ert-info ("Arrange windows for second connection in other frame") + (set-window-buffer (selected-window) "ircd") + (split-window-below) + (set-window-buffer (next-window) "#spam") + (should (equal (cddar (window-tree)) + (list (get-buffer-window "ircd" t) + (get-buffer-window "#spam" t))))) + + (ert-info ("Arrange windows for first connection in server frame") + (select-frame-by-name "server") + (set-window-buffer (selected-window) "server") + (set-window-buffer (next-window) "#chan") + (should (equal (cddar (window-tree)) + (list (get-buffer-window "server" t) + (get-buffer-window "#chan" t))))) + + ;; Select original ERT frame + (ert-info ("New target for connection server finds appropriate frame") + (select-frame orig-frame 'no-record) + (with-current-buffer (window-buffer (selected-window)) + (should (member (buffer-name) '("*ert*" "*scratch*"))) + (with-current-buffer (generate-new-buffer "alice") + (erc-mode) + (erc-tests--servars "server" 'erc-server-process 'erc-networks--id) + (setq erc-default-recipients '("alice")) + (should-not (get-buffer-window (current-buffer) t)) + (erc-setup-buffer (current-buffer)) + ;; Window created in frame "server" + (should (eq (selected-frame) orig-frame)) + (erc-tests--assert-server-split (current-buffer) "server")))) + + (ert-info ("New target for connection ircd finds appropriate frame") + (select-frame orig-frame 'no-record) + (with-current-buffer (window-buffer (selected-window)) + (should (member (buffer-name) '("*ert*" "*scratch*"))) + (with-current-buffer (generate-new-buffer "bob") + (erc-mode) + (erc-tests--servars "ircd" 'erc-server-process 'erc-networks--id) + (setq erc-default-recipients '("bob")) + (should-not (get-buffer-window (current-buffer) t)) + (erc-setup-buffer (current-buffer)) + ;; Window created in frame "other" + (should (eq (selected-frame) orig-frame)) + (erc-tests--assert-server-split (current-buffer) "other"))))) + +(ert-deftest erc-reuse-frames--displayed-full () + :tags '(:unstable :expensive-test) + (erc-tests--erc-reuse-frames + (lambda (orig-frame) + (let ((erc-reuse-frames 'displayed)) + (erc-tests--erc-reuse-frames--displayed-full orig-frame)) + (dolist (b '("server" "ircd" "bob" "alice" "#spam" "#chan")) + (kill-buffer b))))) + (ert-deftest erc-lurker-maybe-trim () (let (erc-lurker-trim-nicks (erc-lurker-ignore-chars "_`")) commit c104e90888a03b4879cd91bf5d130288ac880d66 Author: F. Jason Park Date: Thu Nov 24 21:03:03 2022 -0800 Make auth-source erc-services tests more readable * lisp/erc/erc-common.el: (erc-with-server-buffer): Modify slightly to use `buffer-local-value' when possible. * test/lisp/erc/erc-services-tests.el (erc-services-tests--auth-source-plstore-standard-entries, erc-services-tests--auth-source-plstore-standard-secrets): Remove unused variables. (erc-services-tests--auth-source-plstore-standard-announced): Add new var to hold common plstore document. (erc--auth-source-search--plstore-standard, erc--auth-source-search--plstore-announced, erc--auth-source-search--plstore-overrides): Use string literals for text-document content. (erc-services-tests--auth-source-json-standard-entries): Remove unused variable. (erc-services-tests--auth-source-json-standard-announced): Add new variable. (erc--auth-source-search--json-standard, erc--auth-source-search--json-announced, erc--auth-source-search--json-overrides): Use string literals for text-document content. (erc-services-tests--secrets-search-items): Add new helper function. (erc--auth-source-search--secrets-standard, erc--auth-source-search--secrets-announced, erc--auth-source-search--secrets-overrides): Use helper to mock `secrets-search-items' instead of misleading lambda. * lisp/erc/erc-tests.el (erc-with-server-buffer): Add test. diff --git a/lisp/erc/erc-common.el b/lisp/erc/erc-common.el index 8b23904cb99..6c015c71ff9 100644 --- a/lisp/erc/erc-common.el +++ b/lisp/erc/erc-common.el @@ -367,11 +367,16 @@ erc-with-server-buffer "Execute BODY in the current ERC server buffer. If no server buffer exists, return nil." (declare (indent 0) (debug (body))) - (let ((buffer (make-symbol "buffer"))) + (let ((varp (and (symbolp (car body)) + (not (cdr body)) + (special-variable-p (car body)))) + (buffer (make-symbol "buffer"))) `(let ((,buffer (erc-server-buffer))) (when (buffer-live-p ,buffer) - (with-current-buffer ,buffer - ,@body))))) + ,(if varp + `(buffer-local-value ',(car body) ,buffer) + `(with-current-buffer ,buffer + ,@body)))))) (defmacro erc-with-all-buffers-of-server (process pred &rest forms) "Execute FORMS in all buffers which have same process as this server. diff --git a/test/lisp/erc/erc-services-tests.el b/test/lisp/erc/erc-services-tests.el index 9181a47ee3b..6cbba02a37e 100644 --- a/test/lisp/erc/erc-services-tests.el +++ b/test/lisp/erc/erc-services-tests.el @@ -212,39 +212,32 @@ erc-services-test--call-with-plstore (advice-remove 'epg-decrypt-string 'erc--auth-source-plstore) (advice-remove 'epg-find-configuration 'erc--auth-source-plstore))) -(defvar erc-services-tests--auth-source-plstore-standard-entries - '(("ba950d38118a76d71f9f0591bb373d6cb366a512" - :secret-secret t - :host "irc.gnu.org" - :user "#chan" - :port "irc") - ("7f17ca445d11158065e911a6d0f4cbf52ca250e3" - :secret-secret t - :host "my.gnu.org" - :user "#chan" - :port "irc") - ("fcd3c8bd6daf4509de0ad6ee98e744ce0fca9377" - :secret-secret t - :host "GNU.chat" - :user "#chan" - :port "irc"))) - -(defvar erc-services-tests--auth-source-plstore-standard-secrets - '(("ba950d38118a76d71f9f0591bb373d6cb366a512" :secret "bar") - ("7f17ca445d11158065e911a6d0f4cbf52ca250e3" :secret "baz") - ("fcd3c8bd6daf4509de0ad6ee98e744ce0fca9377" :secret "foo"))) +(defvar erc-services-tests--auth-source-plstore-standard-announced "\ +;;; public entries -*- mode: plstore -*- +((\"ba950d38118a76d71f9f0591bb373d6cb366a512\" + :secret-secret t + :host \"irc.gnu.org\" + :user \"#chan\" + :port \"irc\") + (\"7f17ca445d11158065e911a6d0f4cbf52ca250e3\" + :secret-secret t + :host \"my.gnu.org\" + :user \"#chan\" + :port \"irc\") + (\"fcd3c8bd6daf4509de0ad6ee98e744ce0fca9377\" + :secret-secret t + :host \"GNU.chat\" + :user \"#chan\" + :port \"irc\")) +;;; secret entries +((\"ba950d38118a76d71f9f0591bb373d6cb366a512\" :secret \"bar\") + (\"7f17ca445d11158065e911a6d0f4cbf52ca250e3\" :secret \"baz\") + (\"fcd3c8bd6daf4509de0ad6ee98e744ce0fca9377\" :secret \"foo\"))") (ert-deftest erc--auth-source-search--plstore-standard () (ert-with-temp-file plstore-file :suffix ".plist" - :text (concat ";;; public entries -*- mode: plstore -*- \n" - (prin1-to-string - erc-services-tests--auth-source-plstore-standard-entries) - "\n;;; secret entries\n" - (prin1-to-string - erc-services-tests--auth-source-plstore-standard-secrets) - "\n") - + :text erc-services-tests--auth-source-plstore-standard-announced (let ((auth-sources (list plstore-file)) (auth-source-do-cache nil)) (erc-services-tests--auth-source-standard @@ -254,14 +247,7 @@ erc--auth-source-search--plstore-standard (ert-deftest erc--auth-source-search--plstore-announced () (ert-with-temp-file plstore-file :suffix ".plist" - :text (concat ";;; public entries -*- mode: plstore -*- \n" - (prin1-to-string - erc-services-tests--auth-source-plstore-standard-entries) - "\n;;; secret entries\n" - (prin1-to-string - erc-services-tests--auth-source-plstore-standard-secrets) - "\n") - + :text erc-services-tests--auth-source-plstore-standard-announced (let ((auth-sources (list plstore-file)) (auth-source-do-cache nil)) (erc-services-tests--auth-source-announced @@ -271,29 +257,33 @@ erc--auth-source-search--plstore-announced (ert-deftest erc--auth-source-search--plstore-overrides () (ert-with-temp-file plstore-file :suffix ".plist" - :text (concat - ";;; public entries -*- mode: plstore -*- \n" - (prin1-to-string - `(,@erc-services-tests--auth-source-plstore-standard-entries - ("1b3fab249a8dff77a4d8fe7eb4b0171b25cc711a" - :secret-secret t :host "GNU.chat" :user "#chan" :port "6697") - ("6cbcdc39476b8cfcca6f3e9a7876f41ec3f708cc" - :secret-secret t :host "my.gnu.org" :user "#fsf" :port "irc") - ("a33e2b3bd2d6f33995a4b88710a594a100c5e41d" - :secret-secret t :host "irc.gnu.org" :port "6667") - ("ab2fd349b2b7d6a9215bb35a92d054261b0b1537" - :secret-secret t :host "MyHost" :port "irc") - ("61a6bd552059494f479ff720e8de33e22574650a" - :secret-secret t :host "MyHost" :port "6667"))) - "\n;;; secret entries\n" - (prin1-to-string - `(,@erc-services-tests--auth-source-plstore-standard-secrets - ("1b3fab249a8dff77a4d8fe7eb4b0171b25cc711a" :secret "spam") - ("6cbcdc39476b8cfcca6f3e9a7876f41ec3f708cc" :secret "42") - ("a33e2b3bd2d6f33995a4b88710a594a100c5e41d" :secret "sesame") - ("ab2fd349b2b7d6a9215bb35a92d054261b0b1537" :secret "456") - ("61a6bd552059494f479ff720e8de33e22574650a" :secret "123"))) - "\n") + :text "\ +;;; public entries -*- mode: plstore -*- +((\"ba950d38118a76d71f9f0591bb373d6cb366a512\" + :secret-secret t :host \"irc.gnu.org\" :user \"#chan\" :port \"irc\") + (\"7f17ca445d11158065e911a6d0f4cbf52ca250e3\" + :secret-secret t :host \"my.gnu.org\" :user \"#chan\" :port \"irc\") + (\"fcd3c8bd6daf4509de0ad6ee98e744ce0fca9377\" + :secret-secret t :host \"GNU.chat\" :user \"#chan\" :port \"irc\") + (\"1b3fab249a8dff77a4d8fe7eb4b0171b25cc711a\" + :secret-secret t :host \"GNU.chat\" :user \"#chan\" :port \"6697\") + (\"6cbcdc39476b8cfcca6f3e9a7876f41ec3f708cc\" + :secret-secret t :host \"my.gnu.org\" :user \"#fsf\" :port \"irc\") + (\"a33e2b3bd2d6f33995a4b88710a594a100c5e41d\" + :secret-secret t :host \"irc.gnu.org\" :port \"6667\") + (\"ab2fd349b2b7d6a9215bb35a92d054261b0b1537\" + :secret-secret t :host \"MyHost\" :port \"irc\") + (\"61a6bd552059494f479ff720e8de33e22574650a\" + :secret-secret t :host \"MyHost\" :port \"6667\")) +;;; secret entries +((\"ba950d38118a76d71f9f0591bb373d6cb366a512\" :secret \"bar\") + (\"7f17ca445d11158065e911a6d0f4cbf52ca250e3\" :secret \"baz\") + (\"fcd3c8bd6daf4509de0ad6ee98e744ce0fca9377\" :secret \"foo\") + (\"1b3fab249a8dff77a4d8fe7eb4b0171b25cc711a\" :secret \"spam\") + (\"6cbcdc39476b8cfcca6f3e9a7876f41ec3f708cc\" :secret \"42\") + (\"a33e2b3bd2d6f33995a4b88710a594a100c5e41d\" :secret \"sesame\") + (\"ab2fd349b2b7d6a9215bb35a92d054261b0b1537\" :secret \"456\") + (\"61a6bd552059494f479ff720e8de33e22574650a\" :secret \"123\"))" (let ((auth-sources (list plstore-file)) (auth-source-do-cache nil)) @@ -303,17 +293,24 @@ erc--auth-source-search--plstore-overrides ;; auth-source JSON backend -(defvar erc-services-tests--auth-source-json-standard-entries - [(:host "irc.gnu.org" :port "irc" :user "#chan" :secret "bar") - (:host "my.gnu.org" :port "irc" :user "#chan" :secret "baz") - (:host "GNU.chat" :port "irc" :user "#chan" :secret "foo")]) +(defvar erc-services-tests--auth-source-json-standard-announced "\ +[{\"host\": \"irc.gnu.org\", + \"port\": \"irc\", + \"user\": \"#chan\", + \"secret\": \"bar\"}, + {\"host\": \"my.gnu.org\", + \"port\": \"irc\", + \"user\": \"#chan\", + \"secret\": \"baz\"}, + {\"host\": \"GNU.chat\", + \"port\": \"irc\", + \"user\": \"#chan\", + \"secret\": \"foo\"}]") (ert-deftest erc--auth-source-search--json-standard () (ert-with-temp-file json-store + :text erc-services-tests--auth-source-json-standard-announced :suffix ".json" - :text (let ((json-object-type 'plist)) - (json-encode - erc-services-tests--auth-source-json-standard-entries)) (let ((auth-sources (list json-store)) (auth-source-do-cache nil)) (erc-services-tests--auth-source-standard #'erc-auth-source-search)))) @@ -321,10 +318,7 @@ erc--auth-source-search--json-standard (ert-deftest erc--auth-source-search--json-announced () (ert-with-temp-file plstore-file :suffix ".json" - :text (let ((json-object-type 'plist)) - (json-encode - erc-services-tests--auth-source-json-standard-entries)) - + :text erc-services-tests--auth-source-json-standard-announced (let ((auth-sources (list plstore-file)) (auth-source-do-cache nil)) (erc-services-tests--auth-source-announced #'erc-auth-source-search)))) @@ -332,16 +326,36 @@ erc--auth-source-search--json-announced (ert-deftest erc--auth-source-search--json-overrides () (ert-with-temp-file json-file :suffix ".json" - :text (let ((json-object-type 'plist)) - (json-encode - (vconcat - erc-services-tests--auth-source-json-standard-entries - [(:secret "spam" :host "GNU.chat" :user "#chan" :port "6697") - (:secret "42" :host "my.gnu.org" :user "#fsf" :port "irc") - (:secret "sesame" :host "irc.gnu.org" :port "6667") - (:secret "456" :host "MyHost" :port "irc") - (:secret "123" :host "MyHost" :port "6667")]))) - + :text "\ +[{\"host\": \"irc.gnu.org\", + \"port\": \"irc\", + \"user\": \"#chan\", + \"secret\": \"bar\"}, + {\"host\": \"my.gnu.org\", + \"port\": \"irc\", + \"user\": \"#chan\", + \"secret\": \"baz\"}, + {\"host\": \"GNU.chat\", + \"port\": \"irc\", + \"user\": \"#chan\", + \"secret\": \"foo\"}, + {\"host\": \"GNU.chat\", + \"user\": \"#chan\", + \"port\": \"6697\", + \"secret\": \"spam\"}, + {\"host\": \"my.gnu.org\", + \"user\": \"#fsf\", + \"port\": \"irc\", + \"secret\": \"42\"}, + {\"host\": \"irc.gnu.org\", + \"port\": \"6667\", + \"secret\": \"sesame\"}, + {\"host\": \"MyHost\", + \"port\": \"irc\", + \"secret\": \"456\"}, + {\"host\": \"MyHost\", + \"port\": \"6667\", + \"secret\": \"123\"}]" (let ((auth-sources (list json-file)) (auth-source-do-cache nil)) (erc-services-tests--auth-source-overrides #'erc-auth-source-search)))) @@ -370,6 +384,14 @@ erc-services-tests--auth-source-secrets-standard-secrets ("#chan@my.gnu.org:irc" . "baz") ("#chan@GNU.chat:irc" . "foo"))) +(defun erc-services-tests--secrets-search-items (entries _ &rest r) + (mapcan (lambda (s) + (and (seq-every-p (pcase-lambda (`(,k . ,v)) + (equal v (alist-get k (cdr s)))) + (map-pairs r)) + (list (car s)))) + entries)) + (ert-deftest erc--auth-source-search--secrets-standard () (skip-unless (bound-and-true-p secrets-enabled)) (let ((auth-sources '("secrets:Test")) @@ -378,18 +400,12 @@ erc--auth-source-search--secrets-standard (secrets erc-services-tests--auth-source-secrets-standard-secrets)) (cl-letf (((symbol-function 'secrets-search-items) - (lambda (col &rest r) - (should (equal col "Test")) - (should (plist-get r :user)) - (map-keys entries))) + (apply-partially #'erc-services-tests--secrets-search-items + entries)) ((symbol-function 'secrets-get-secret) - (lambda (col label) - (should (equal col "Test")) - (assoc-default label secrets))) + (lambda (_ label) (assoc-default label secrets))) ((symbol-function 'secrets-get-attributes) - (lambda (col label) - (should (equal col "Test")) - (assoc-default label entries)))) + (lambda (_ label) (assoc-default label entries)))) (erc-services-tests--auth-source-standard #'erc-auth-source-search)))) @@ -401,18 +417,12 @@ erc--auth-source-search--secrets-announced (secrets erc-services-tests--auth-source-secrets-standard-secrets)) (cl-letf (((symbol-function 'secrets-search-items) - (lambda (col &rest r) - (should (equal col "Test")) - (should (plist-get r :user)) - (map-keys entries))) + (apply-partially #'erc-services-tests--secrets-search-items + entries)) ((symbol-function 'secrets-get-secret) - (lambda (col label) - (should (equal col "Test")) - (assoc-default label secrets))) + (lambda (_ label) (assoc-default label secrets))) ((symbol-function 'secrets-get-attributes) - (lambda (col label) - (should (equal col "Test")) - (assoc-default label entries)))) + (lambda (_ label) (assoc-default label entries)))) (erc-services-tests--auth-source-announced #'erc-auth-source-search)))) @@ -444,17 +454,12 @@ erc--auth-source-search--secrets-overrides ("MyHost:6667" . "123")))) (cl-letf (((symbol-function 'secrets-search-items) - (lambda (col &rest _) - (should (equal col "Test")) - (map-keys entries))) + (apply-partially #'erc-services-tests--secrets-search-items + entries)) ((symbol-function 'secrets-get-secret) - (lambda (col label) - (should (equal col "Test")) - (assoc-default label secrets))) + (lambda (_ label) (assoc-default label secrets))) ((symbol-function 'secrets-get-attributes) - (lambda (col label) - (should (equal col "Test")) - (assoc-default label entries)))) + (lambda (_ label) (assoc-default label entries)))) (erc-services-tests--auth-source-overrides #'erc-auth-source-search)))) diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index b155f85ab8a..43a5b54dcc7 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -113,6 +113,22 @@ erc-with-all-buffers-of-server (should (get-buffer "#spam")) (kill-buffer "#spam"))) +(ert-deftest erc-with-server-buffer () + (setq erc-away 1) + (erc-tests--set-fake-server-process "sleep" "1") + + (let (calls) + (advice-add 'buffer-local-value :after (lambda (&rest r) (push r calls)) + '((name . erc-with-server-buffer))) + + (should (= 1 (erc-with-server-buffer erc-away))) + (should (equal (pop calls) (list 'erc-away (current-buffer)))) + + (should (= 1 (erc-with-server-buffer (ignore 'me) erc-away))) + (should-not calls) + + (advice-remove 'buffer-local-value 'erc-with-server-buffer))) + (defun erc-tests--send-prep () ;; Caller should probably shadow `erc-insert-modify-hook' or ;; populate user tables for erc-button. commit 8184a815aff52cbf1f1b8680d80af2fbf2dce248 Author: F. Jason Park Date: Sun Dec 18 19:01:40 2022 -0800 Add erc-button helper for substituting command keys * lisp/erc/erc-button.el (erc-button-mode, erc-button-enable): Warn if `erc-button-alist' contains deprecated FORM field in `nicknames' entry. (erc-button-alist): Discourage arbitrary sexp form for third item of entries and offer more useful bounds-modifying function in its place. Mention that anything other than `erc-button-buttonize-nicks' is deprecated as the FORM field in a `nicknames' entry. Bump package-version even though this doesn't introduce a visible change in the default value. (erc-button--maybe-warn-arbitrary-sexp): Add helper for validating third `erc-button-alist' field. (erc-button--check-nicknames-entry): Add helper to check for deprecated items in `erc-button-alist'. (erc-button--preserve-bounds): Add function to serve as default value for `erc-button--modify-nick-function). (erc-button--modify-nick-function): Add new variable to hold a function that filters nickname bounds when buttonizing. (erc-button--phantom-users, erc-button--add-phantom-speaker, erc-button--phantom-users-mode): Add new internal minor mode for treating unseen speakers of PRIVMSGs as known members of the server for things like coloring nicks during buffer playback. (erc-button--get-user-from-speaker-naive): Add temporary utility function to scrape nick from speaker in narrowed buffer. This will be replaced by an account-aware version in next major ERC release. (erc-button-add-nickname-buttons): Accommodate function variant for "form" field of `erc-button-alist' entries. Minor optimizations. This function will likely become the primary juncture for applying text properties that support nickname-related user-intelligence features. (erc-button-add-buttons-1): Show warning when arbitrary sexp for third "form" field encountered. Accommodate binary function instead. (erc-button--substitute-command-keys-in-region): Add helper function for applying key substitutions in ERC warning messages. (erc-button--display-error-notice-with-keys): Add new helper function for displaying ad hoc warnings that possibly require key substitution. (erc-button--display-error-notice-with-keys-and-warn): Add variant of `erc-button--display-error-notice-with-keys' that also emits warnings. * lisp/erc/erc-networks.el (erc-networks--ensure-announced, erc-networks--on-MOTD-end): Use new key-substitutions helper from erc-button. * test/lisp/erc/erc-tests.el (erc-button--display-error-notice-with-keys): New test. * test/lisp/erc/resources/base/assoc/bouncer-history/foonet.eld: Add unknown speaker in channel for phantom store to handle. Currently requires manual intervention to leverage. (Bug#60933.) diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el index 48f6a5d1794..33e69f3b0b8 100644 --- a/lisp/erc/erc-button.el +++ b/lisp/erc/erc-button.el @@ -52,7 +52,8 @@ erc-button ;;;###autoload(autoload 'erc-button-mode "erc-button" nil t) (define-erc-module button nil "This mode buttonizes all messages according to `erc-button-alist'." - ((add-hook 'erc-insert-modify-hook #'erc-button-add-buttons 'append) + ((erc-button--check-nicknames-entry) + (add-hook 'erc-insert-modify-hook #'erc-button-add-buttons 'append) (add-hook 'erc-send-modify-hook #'erc-button-add-buttons 'append) (add-hook 'erc-complete-functions #'erc-button-next-function) (erc--modify-local-map t "" #'erc-button-previous)) @@ -165,8 +166,17 @@ erc-button-alist BUTTON is the number of the regexp grouping actually matching the button. This is ignored if REGEXP is `nicknames'. -FORM is a Lisp expression which must eval to true for the button to - be added. +FORM is a Lisp symbol for a special variable whose value must be + true for the button to be added. Alternatively, when REGEXP is + not `nicknames', FORM can be a function whose arguments are BEG + and END, the bounds of the button in the current buffer. It's + expected to return a cons of (possibly identical) bounds or + nil, to deny. For the extent of the call, all face options + defined for the button module are re-bound, shadowing + themselves, so the function is free to change their values. + When regexp is the special symbol `nicknames', FORM must be the + symbol `erc-button-buttonize-nicks'. Specifying anything else + is deprecated. CALLBACK is the function to call when the user push this button. CALLBACK can also be a symbol. Its variable value will be used @@ -176,7 +186,7 @@ erc-button-alist CALLBACK. There can be several PAR arguments. If REGEXP is `nicknames', these are ignored, and CALLBACK will be called with the nickname matched as the argument." - :package-version '(ERC . "5.5") + :package-version '(ERC . "5.6") ; FIXME sync on release :type '(repeat (list :tag "Button" (choice :tag "Matches" @@ -277,22 +287,127 @@ erc-button-add-buttons (concat "\\<" (regexp-quote (car elem)) "\\>") entry))))))))))) +(defun erc-button--maybe-warn-arbitrary-sexp (form) + (if (and (symbolp form) (special-variable-p form)) + (symbol-value form) + (unless (get 'erc-button--maybe-warn-arbitrary-sexp 'warned-arbitrary-sexp) + (put 'erc-button--maybe-warn-arbitrary-sexp 'warned-arbitrary-sexp t) + (lwarn 'erc :warning + (concat "Arbitrary sexps for the third FORM" + " slot of `erc-button-alist' entries" + " have been deprecated."))) + (eval form t))) + +(defun erc-button--check-nicknames-entry () + ;; This helper exists because the module is defined after its options. + (when-let (((eq major-mode 'erc-mode)) + (entry (alist-get 'nicknames erc-button-alist))) + (unless (eq 'erc-button-buttonize-nicks (nth 1 entry)) + (erc-button--display-error-notice-with-keys-and-warn + "Values other than `erc-button-buttonize-nicks' in the third slot of " + "the `nicknames' entry of `erc-button-alist' are deprecated.")))) + +(defun erc-button--preserve-bounds (bounds _ server-user _) + "Return BOUNDS.\n\n(fn BOUNDS NICKNAME SERVER-USER CHANNEL-USER)" + (and server-user bounds)) + +;; This variable is intended to serve as a "core" to be wrapped by +;; (built-in) modules during setup. It's unclear whether +;; `add-function's practice of removing existing advice before +;; re-adding it is desirable when integrating modules since we're +;; mostly concerned with ensuring one "piece" precedes or follows +;; another (specific piece), which may not yet (or ever) be present. + +(defvar erc-button--modify-nick-function #'erc-button--preserve-bounds + "Function to possibly modify aspects of nick being buttonized. +Called with four args: BOUNDS NICKNAME SERVER-USER CHANNEL-USER. +BOUNDS is a cons of (BEG . END) marking the position of the nick +in the current message, which occupies the whole of the narrowed +buffer. BEG is normally also point. NICKNAME is a case-mapped +string without text properties. SERVER-USER and CHANNEL-USER are +the nick's `erc-server-users' entry and its associated (though +possibly nil) `erc-channel-user' object. The function should +return BOUNDS or a suitable replacement to indicate that +buttonizing ought to proceed, and nil if it should be inhibited.") + +(defvar-local erc-button--phantom-users nil) + +(defun erc-button--add-phantom-speaker (args) + "Maybe substitute fake `server-user' for speaker at point." + (pcase args + (`(,bounds ,downcased-nick nil ,channel-user) + (list bounds downcased-nick + ;; Like `with-memoization' but don't cache when value is nil. + (or (gethash downcased-nick erc-button--phantom-users) + (and-let* ((user (erc-button--get-user-from-speaker-naive + (car bounds)))) + (puthash downcased-nick user erc-button--phantom-users))) + channel-user)) + (_ args))) + +(define-minor-mode erc-button--phantom-users-mode + "Minor mode to recognize unknown speakers. +Expect to be used by module setup code for creating placeholder +users on the fly during history playback. Treat an unknown +PRIVMSG speaker, like , as if they were present in a 353 and +are thus a member of the channel. However, don't bother creating +an actual `erc-channel-user' object because their status prefix +is unknown. Instead, just spoof an `erc-server-user' by applying +early (outer), args-filtering advice wrapping +`erc-button--modify-nick-function'." + :interactive nil + (if erc-button--phantom-users-mode + (progn + (add-function :filter-args (local 'erc-button--modify-nick-function) + #'erc-button--add-phantom-speaker '((depth . -90))) + (setq erc-button--phantom-users (make-hash-table :test #'equal))) + (remove-function (local 'erc-button--modify-nick-function) + #'erc-button--add-phantom-speaker) + (kill-local-variable 'erc-nicks--phantom-users))) + +;; FIXME replace this after making ERC account-aware. +(defun erc-button--get-user-from-speaker-naive (point) + "Return `erc-server-user' object for nick at POINT." + (when-let* + (((eql ?< (char-before point))) + ((eq (get-text-property point 'font-lock-face) 'erc-nick-default-face)) + (parsed (erc-get-parsed-vector point))) + (pcase-let* ((`(,nick ,login ,host) + (erc-parse-user (erc-response.sender parsed)))) + (make-erc-server-user + :nickname nick + :host (and (not (string-empty-p host)) host) + :login (and (not (string-empty-p login)) login))))) + (defun erc-button-add-nickname-buttons (entry) "Search through the buffer for nicknames, and add buttons." (let ((form (nth 2 entry)) (fun (nth 3 entry)) bounds word) - (when (or (eq t form) - (eval form t)) + (when (eq form 'erc-button-buttonize-nicks) + (setq form (and (symbol-value form) erc-button--modify-nick-function))) + (when (or (functionp form) + (eq t form) + (and form (erc-button--maybe-warn-arbitrary-sexp form))) (goto-char (point-min)) (while (erc-forward-word) (when (setq bounds (erc-bounds-of-word-at-point)) (setq word (buffer-substring-no-properties (car bounds) (cdr bounds))) - (when (or (and (erc-server-buffer-p) (erc-get-server-user word)) - (and erc-channel-users (erc-get-channel-user word))) - (erc-button-add-button (car bounds) (cdr bounds) - fun t (list word)))))))) + (let* ((erc-button-face erc-button-face) + (erc-button-mouse-face erc-button-mouse-face) + (erc-button-nickname-face erc-button-nickname-face) + (down (erc-downcase word)) + (cuser (and erc-channel-users + (gethash down erc-channel-users))) + (user (or (and cuser (car cuser)) + (and erc-server-users + (gethash down erc-server-users))))) + (when (or (not (functionp form)) + (setq bounds + (funcall form bounds down user (cdr cuser)))) + (erc-button-add-button (car bounds) (cdr bounds) + fun t (list word))))))))) (defun erc-button-add-buttons-1 (regexp entry) "Search through the buffer for matches to ENTRY and add buttons." @@ -304,7 +419,14 @@ erc-button-add-buttons-1 (fun (nth 3 entry)) (data (mapcar #'match-string-no-properties (nthcdr 4 entry)))) (when (or (eq t form) - (eval form t)) + (and (functionp form) + (let* ((erc-button-face erc-button-face) + (erc-button-mouse-face erc-button-mouse-face) + (erc-button-nickname-face erc-button-nickname-face) + (rv (funcall form start end))) + (when rv + (setq end (cdr rv) start (car rv))))) + (erc-button--maybe-warn-arbitrary-sexp form)) (erc-button-add-button start end fun nil data regexp))))) (defun erc-button-remove-old-buttons () @@ -513,6 +635,70 @@ erc-button-beats-to-time (message "@%s is %d:%02d local time" beats hours minutes))) +(defun erc-button--substitute-command-keys-in-region (beg end) + "Replace command in region with keys and return new bounds" + (let* ((o (buffer-substring beg end)) + (s (substitute-command-keys o))) + (unless (equal o s) + (setq erc-button-face nil)) + (delete-region beg end) + (insert s)) + (cons beg (point))) + +;;;###autoload +(defun erc-button--display-error-notice-with-keys (&optional parsed buffer + &rest strings) + "Add help keys to STRINGS for configuration-related admonishments. +Return inserted result. Expect PARSED to be an `erc-response' +object, a string, or nil. Expect BUFFER to be a buffer, a string, +or nil. As a special case, allow PARSED to be a buffer as long +as BUFFER is a string or nil. If STRINGS contains any trailing +non-strings, concatenate leading string members before applying +`format'. Otherwise, just concatenate everything." + (when (stringp buffer) + (push buffer strings) + (setq buffer nil)) + (when (stringp parsed) + (push parsed strings) + (setq parsed nil)) + (when (bufferp parsed) + (cl-assert (null buffer)) + (setq buffer parsed + parsed nil)) + (let* ((op (if (seq-every-p #'stringp (cdr strings)) + #'concat + (let ((head (pop strings))) + (while (stringp (car strings)) + (setq head (concat head (pop strings)))) + (push head strings)) + #'format)) + (string (apply op strings)) + (erc-insert-post-hook + (cons (lambda () + (setq string (buffer-substring (point-min) + (1- (point-max))))) + erc-insert-post-hook)) + (erc-button-alist + `((,(rx "\\[" (group (+ (not "]"))) "]") 0 + erc-button--substitute-command-keys-in-region + erc-button-describe-symbol 1) + ,@erc-button-alist))) + (erc-display-message parsed '(notice error) (or buffer 'active) string) + string)) + +;;;###autoload +(defun erc-button--display-error-notice-with-keys-and-warn (&rest args) + "Like `erc-button--display-error-notice-with-keys' but also warn." + (let ((string (apply #'erc-button--display-error-notice-with-keys args))) + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (with-syntax-table lisp-mode-syntax-table + (skip-syntax-forward "^-")) + (forward-char) + (display-warning + 'erc (buffer-substring-no-properties (point) (point-max)))))) + (provide 'erc-button) ;;; erc-button.el ends here diff --git a/lisp/erc/erc-networks.el b/lisp/erc/erc-networks.el index 4337d633cfa..dd481032e7e 100644 --- a/lisp/erc/erc-networks.el +++ b/lisp/erc/erc-networks.el @@ -67,6 +67,9 @@ erc-session-server (declare-function erc-server-process-alive "erc-backend" (&optional buffer)) (declare-function erc-set-active-buffer "erc" (buffer)) +(declare-function erc-button--display-error-notice-with-keys + (parsed &rest strings)) + ;; Variables (defgroup erc-networks nil @@ -1310,12 +1313,11 @@ erc-networks--ensure-announced Copy source (prefix) from MOTD-ish message as a last resort." ;; The 004 handler never ran; see 2004-03-10 Diane Murray in change log (unless erc-server-announced-name - (setq erc-server-announced-name (erc-response.sender parsed)) - (erc-display-error-notice - parsed (concat "Failed to determine server name. Using \"" - erc-server-announced-name "\" instead." - " If this was unexpected, consider reporting it via " - (substitute-command-keys "\\[erc-bug]") "."))) + (require 'erc-button) + (erc-button--display-error-notice-with-keys + parsed "Failed to determine server name. Using \"" + (setq erc-server-announced-name (erc-response.sender parsed)) "\" instead" + ". If this was unexpected, consider reporting it via \\[erc-bug]" ".")) nil) (defun erc-unset-network-name (_nick _ip _reason) @@ -1493,9 +1495,9 @@ erc-networks-on-MOTD-end (memq (erc--target-symbol erc--target) erc-networks--bouncer-targets))) proc) - (let ((m (concat "Unexpected state detected. Please report via " - (substitute-command-keys "\\[erc-bug]") "."))) - (erc-display-error-notice parsed m)))) + (require 'erc-button) + (erc-button--display-error-notice-with-keys + parsed "Unexpected state detected. Please report via \\[erc-bug]."))) ;; For now, retain compatibility with erc-server-NNN-functions. (or (erc-networks--ensure-announced proc parsed) diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index 6e66de53edd..b155f85ab8a 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -1790,4 +1790,65 @@ define-erc-module--local (put 'erc-mname-enable 'definition-name 'mname) (put 'erc-mname-disable 'definition-name 'mname)))))) + +;; XXX move erc-button tests to new file if more added. +(require 'erc-button) + +;; See also `erc-scenarios-networks-announced-missing' in +;; erc-scenarios-misc.el for a more realistic example. +(ert-deftest erc-button--display-error-notice-with-keys () + (with-current-buffer (get-buffer-create "*fake*") + (let ((mode erc-button-mode) + (inhibit-message noninteractive) + erc-modules + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + (erc-mode) + (erc-tests--set-fake-server-process "sleep" "1") + (erc--initialize-markers (point) nil) + (erc-button-mode +1) + (should (equal (erc-button--display-error-notice-with-keys + "If \\[erc-bol] fails, " + "see \\[erc-bug] or `erc-mode-map'.") + "*** If C-a fails, see M-x erc-bug or `erc-mode-map'.")) + (goto-char (point-min)) + + (ert-info ("Keymap substitution succeeds") + (erc-button-next) + (should (looking-at "C-a")) + (should (eq (get-text-property (point) 'mouse-face) 'highlight)) + (erc-button-press-button) + (with-current-buffer "*Help*" + (goto-char (point-min)) + (should (search-forward "erc-bol" nil t))) + (erc-button-next) + (erc-button-previous) ; end of interval correct + (should (looking-at "a fails"))) + + (ert-info ("Extended command mapping succeeds") + (erc-button-next) + (should (looking-at "M-x erc-bug")) + (erc-button-press-button) + (should (eq (get-text-property (point) 'mouse-face) 'highlight)) + (with-current-buffer "*Help*" + (goto-char (point-min)) + (should (search-forward "erc-bug" nil t)))) + + (ert-info ("Symbol-description face preserved") ; mutated by d-e-n-w-k + (erc-button-next) + (should (equal (get-text-property (point) 'font-lock-face) + '(erc-button erc-error-face))) + (should (eq (get-text-property (point) 'mouse-face) 'highlight)) + (should (eq erc-button-face 'erc-button))) ; extent evaporates + + (ert-info ("Format when trailing args include non-strings") + (should (equal (erc-button--display-error-notice-with-keys + "abc" " %d def" " 45%s" 123 '\6) + "*** abc 123 def 456"))) + + (when noninteractive + (unless mode + (erc-button-mode -1)) + (kill-buffer "*Help*") + (kill-buffer))))) + ;;; erc-tests.el ends here diff --git a/test/lisp/erc/resources/base/assoc/bouncer-history/foonet.eld b/test/lisp/erc/resources/base/assoc/bouncer-history/foonet.eld index 58df79e19fa..f34ae02f4e4 100644 --- a/test/lisp/erc/resources/base/assoc/bouncer-history/foonet.eld +++ b/test/lisp/erc/resources/base/assoc/bouncer-history/foonet.eld @@ -27,6 +27,7 @@ (0 ":bob!~u@svpn88yjcdj42.irc PRIVMSG #chan :[07:04:02] alice: Here come the lovers, full of joy and mirth.") (0 ":alice!~u@svpn88yjcdj42.irc PRIVMSG #chan :[07:04:07] bob: According to the fool's bolt, sir, and such dulcet diseases.") (0 ":bob!~u@svpn88yjcdj42.irc PRIVMSG #chan :[07:04:10] alice: And hang himself. I pray you, do my greeting.") + (0 ":someone!~u@abcdefg.irc PRIVMSG #chan :[07:04:10] hi everyone.") (0 ":alice!~u@svpn88yjcdj42.irc PRIVMSG #chan :[07:04:18] bob: And you sat smiling at his cruel prey.") (0 ":bob!~u@svpn88yjcdj42.irc PRIVMSG #chan :[07:04:21] alice: Or never after look me in the face.") (0 ":alice!~u@svpn88yjcdj42.irc PRIVMSG #chan :[07:04:25] bob: If that may be, than all is well. Come, sit down, every mother's son, and rehearse your parts. Pyramus, you begin: when you have spoken your speech, enter into that brake; and so every one according to his cue.") commit 1f1cd467c6afc8100a338e9b44bae8cebfa093f6 Author: F. Jason Park Date: Sun Dec 18 19:01:40 2022 -0800 Replace Info-goto-node with info in erc-button-alist * lisp/erc/erc-button.el (erc-button-alist): Replace `Info-goto-node' with plain `info', which is autoloaded. Expand regexp to recognize inline `info' function calls. * lisp/erc/erc-networks.el (erc-networks--set-name, erc-networks--warn-on-connect): Don't require `info'. (Bug#60933.) diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el index 1be56f5dc21..48f6a5d1794 100644 --- a/lisp/erc/erc-button.el +++ b/lisp/erc/erc-button.el @@ -133,7 +133,7 @@ erc-button-alist ("[`‘]\\([a-zA-Z][-a-zA-Z_0-9!*<=>+]+\\)['’]" 1 t erc-button-describe-symbol 1) ;; pseudo links - ("\\bInfo:[\"]\\([^\"]+\\)[\"]" 0 t Info-goto-node 1) + ("\\(?:\\bInfo: ?\\|(info \\)[\"]\\(([^\"]+\\)[\"])?" 0 t info 1) ("\\b\\(Ward\\|Wiki\\|WardsWiki\\|TheWiki\\):\\([A-Z][a-z]+\\([A-Z][a-z]+\\)+\\)" 0 t (lambda (page) (browse-url (concat "http://c2.com/cgi-bin/wiki?" page))) diff --git a/lisp/erc/erc-networks.el b/lisp/erc/erc-networks.el index 95fd8990c99..4337d633cfa 100644 --- a/lisp/erc/erc-networks.el +++ b/lisp/erc/erc-networks.el @@ -1292,7 +1292,6 @@ erc-networks--set-name erc-server-announced-name "\" in `erc-networks-alist'" " or consider calling `erc-tls' with the keyword `:id'." " See Info:\"(erc) Network Identifier\" for more."))) - (require 'info) (erc-display-error-notice parsed m) (if erc-networks--allow-unknown-network (progn @@ -1514,7 +1513,6 @@ erc-networks--warn-on-connect "Emit warning when the `networks' module hasn't been loaded. Ideally, do so upon opening the network process." (unless (or erc--target erc-networks-mode) - (require 'info nil t) (let ((m (concat "Required module `networks' not loaded. If this " " was unexpected, please add it to `erc-modules'."))) ;; Assume the server buffer has been marked as active. commit 4b56739547c93598d420c44dc7ae89129ccd912a Author: F. Jason Park Date: Fri Jan 13 00:00:56 2023 -0800 Add erc-fill style based on visual-line-mode * lisp/erc/erc-fill.el (erc-fill-function): Add new value `erc-fill-wrap'. (erc-fill-static-center): Extend meaning of option to also affect `erc-wrap-mode'. (erc-fill--wrap-value, erc-fill--wrap-visual-keys): New variables to support new local module. (erc-fill-wrap-visual-keys): New option to control how and where `visual-line-mode' keys are active. (erc-fill-wrap-merge): Add option for omitting a speaker's name if they just now spoke. Enabled by default. (erc-fill--wrap-move): New helper function for fill-wrap movement commands. (erc-fill--wrap-kill-line, erc-fill--wrap-beginning-of-line, erc-fill--wrap-end-of-line): New movement commands. (erc-fill-wrap-cycle-visual-movement): New command to cycle local copy of `erc-fill-wrap-visual-keys'. (erc-fill-wrap-mode-map): New keymap based on `visual-line-mode-map'. (erc-fill--make-module-dependency-msg): Helper for `erc-fill-wrap-enable'. (erc-fill-wrap-mode, erc-fill-wrap-enable, erc-fill-wrap-disable): New local module. (erc-fill--wrap-length-function): Internal interface in the form of a function variable for other modules to control the fill-wrap overhang. (erc-fill--wrap-last-msg, erc-fill--wrap-max-lull, erc-fill--wrap-continued-message-p): Add items to support hiding of redundant speaker names in consecutive messages. (erc-fill--wrap-stamp-insert-prefixed-date): New function to add `line-prefix' property to inserted date stamp. (erc-fill-wrap): New function implementing the `erc-fill-function' (behavioral) interface. (erc-fill--wrap-fix): New, possibly temporary function for other modules to fix misalignment caused by fill-wrap. (erc-fill-wrap-nudge, erc-fill--wrap-nudge): New command and helper for growing and shrinking visual fill prefix. * test/lisp/erc/erc-fill-tests.el: New file. (Bug#60936.) * test/lisp/erc/resources/fill/snapshots/merge-01-start.eld: New file. * test/lisp/erc/resources/fill/snapshots/merge-02-right.eld: New file. * test/lisp/erc/resources/fill/snapshots/monospace-01-start.eld: New file. * test/lisp/erc/resources/fill/snapshots/monospace-02-right.eld: New file. * test/lisp/erc/resources/fill/snapshots/monospace-03-left.eld: New file. * test/lisp/erc/resources/fill/snapshots/monospace-04-reset.eld: New file. diff --git a/lisp/erc/erc-fill.el b/lisp/erc/erc-fill.el index caf401bf222..c29d292abce 100644 --- a/lisp/erc/erc-fill.el +++ b/lisp/erc/erc-fill.el @@ -28,6 +28,9 @@ ;; `erc-fill-mode' to switch it on. Customize `erc-fill-function' to ;; change the style. +;; TODO: redo `erc-fill-wrap-nudge' using transient after ERC drops +;; support for Emacs 27. + ;;; Code: (require 'erc) @@ -79,16 +82,29 @@ erc-fill-function These two styles are implemented using `erc-fill-variable' and `erc-fill-static'. You can, of course, define your own filling function. Narrowing to the region in question is in effect while your -function is called." +function is called. + +A third style resembles static filling but \"wraps\" instead of +fills, thanks to `visual-line-mode' mode, which ERC automatically +enables when this option is `erc-fill-wrap' or when +`erc-fill-wrap-mode' is active. Set `erc-fill-static-center' to +your preferred initial \"prefix\" width. For adjusting the width +during a session, see the command `erc-fill-wrap-nudge'." :type '(choice (const :tag "Variable Filling" erc-fill-variable) (const :tag "Static Filling" erc-fill-static) + (const :tag "Dynamic word-wrap" erc-fill-wrap) function)) (defcustom erc-fill-static-center 27 - "Column around which all statically filled messages will be centered. -This column denotes the point where the ` ' character between - and the entered text will be put, thus aligning nick -names right and text left." + "Number of columns to \"outdent\" the first line of a message. +During early message handing, ERC prepends a span of +non-whitespace characters to every message, such as a bracketed +\"\" or an `erc-notice-prefix'. The +`erc-fill-function' variants `erc-fill-static' and +`erc-fill-wrap' look to this option to determine the amount of +padding to apply to that portion until the filled (or wrapped) +message content aligns with the indicated column. See also +https://en.wikipedia.org/wiki/Hanging_indent." :type 'integer) (defcustom erc-fill-variable-maximum-indentation 17 @@ -155,6 +171,326 @@ erc-fill-variable (erc-fill-regarding-timestamp)))) (erc-restore-text-properties))) +(defvar-local erc-fill--wrap-value nil) +(defvar-local erc-fill--wrap-visual-keys nil) + +(defcustom erc-fill-wrap-use-pixels t + "Whether to calculate padding in pixels when possible. +A value of nil means ERC should use columns, which may happen +regardless, depending on the Emacs version. This option only +matters when `erc-fill-wrap-mode' is enabled." + :package-version '(ERC . "5.6") ; FIXME sync on release + :type 'boolean) + +(defcustom erc-fill-wrap-visual-keys 'non-input + "Whether to retain keys defined by `visual-line-mode'. +A value of t tells ERC to use movement commands defined by +`visual-line-mode' everywhere in an ERC buffer along with visual +editing commands in the input area. A value of nil means to +never do so. A value of `non-input' tells ERC to act like the +value is nil in the input area and t elsewhere. This option only +plays a role when `erc-fill-wrap-mode' is enabled." + :package-version '(ERC . "5.6") ; FIXME sync on release + :type '(choice (const nil) (const t) (const non-input))) + +(defcustom erc-fill-wrap-merge t + "Whether to consolidate messages from the same speaker. +This tells ERC to omit redundant speaker labels for subsequent +messages less than a day apart." + :package-version '(ERC . "5.6") ; FIXME sync on release + :type 'boolean) + +(defun erc-fill--wrap-move (normal-cmd visual-cmd arg) + (funcall (pcase erc-fill--wrap-visual-keys + ('non-input + (if (>= (point) erc-input-marker) normal-cmd visual-cmd)) + ('t visual-cmd) + (_ normal-cmd)) + arg)) + +(defun erc-fill--wrap-kill-line (arg) + "Defer to `kill-line' or `kill-visual-line'." + (interactive "P") + ;; ERC buffers are read-only outside of the input area, but we run + ;; `kill-line' anyway so that users can see the error. + (erc-fill--wrap-move #'kill-line #'kill-visual-line arg)) + +(defun erc-fill--wrap-beginning-of-line (arg) + "Defer to `move-beginning-of-line' or `beginning-of-visual-line'." + (interactive "^p") + (let ((inhibit-field-text-motion t)) + (erc-fill--wrap-move #'move-beginning-of-line + #'beginning-of-visual-line arg)) + (when (get-text-property (point) 'erc-prompt) + (goto-char erc-input-marker))) + +(defun erc-fill--wrap-end-of-line (arg) + "Defer to `move-end-of-line' or `end-of-visual-line'." + (interactive "^p") + (erc-fill--wrap-move #'move-end-of-line #'end-of-visual-line arg)) + +(defun erc-fill-wrap-cycle-visual-movement (arg) + "Cycle through `erc-fill-wrap-visual-keys' styles ARG times. +Go from nil to t to `non-input' and back around, but set internal +state instead of mutating `erc-fill-wrap-visual-keys'. When ARG +is 0, reset to value of `erc-fill-wrap-visual-keys'." + (interactive "^p") + (when (zerop arg) + (setq erc-fill--wrap-visual-keys erc-fill-wrap-visual-keys)) + (while (not (zerop arg)) + (cl-incf arg (- (abs arg))) + (setq erc-fill--wrap-visual-keys (pcase erc-fill--wrap-visual-keys + ('nil t) + ('t 'non-input) + ('non-input nil)))) + (message "erc-fill-wrap movement: %S" erc-fill--wrap-visual-keys)) + +(defvar-keymap erc-fill-wrap-mode-map ; Compat 29 + :doc "Keymap for ERC's `fill-wrap' module." + :parent visual-line-mode-map + " " #'erc-fill--wrap-kill-line + " " #'erc-fill--wrap-end-of-line + " " #'erc-fill--wrap-beginning-of-line + "C-c a" #'erc-fill-wrap-cycle-visual-movement + ;; Not sure if this is problematic because `erc-bol' takes no args. + " " #'erc-fill--wrap-beginning-of-line) + +(defvar erc-match-mode) +(defvar erc-button-mode) +(defvar erc-match--hide-fools-offset-bounds) + +(defun erc-fill--make-module-dependency-msg (module) + (concat "Enabling default global module `" module "' needed by local" + " module `fill-wrap'. This will impact \C-]all\C-] ERC" + " sessions. Add `" module "' to `erc-modules' to avoid this" + " warning. See Info:\"(erc) Modules\" for more.")) + +;;;###autoload(put 'fill-wrap 'erc--feature 'erc-fill) +(define-erc-module fill-wrap nil + "Fill style leveraging `visual-line-mode'. +This module displays nickname labels for speakers as overhanging +leftward (and thus right-aligned) to a common offset, as +determined by the option `erc-fill-static-center'. It depends on +the `fill' and `button' modules and assumes the option +`erc-insert-timestamp-function' is `erc-insert-timestamp-right' +or `erc-insert-timestamp-left-and-right' (recommended) so that it +can display right-hand stamps in the right margin. A value of +`erc-insert-timestamp-left' is unsupported. This local module +depends on the global `fill' module. To use it, either include +`fill-wrap' in `erc-modules' or set `erc-fill-function' to +`erc-fill-wrap' (recommended). You can also manually invoke one +of the minor-mode toggles as usual." + ((let (msg) + (unless erc-fill-mode + (unless (memq 'fill erc-modules) + (setq msg + ;; FIXME use `erc-button--display-error-notice-with-keys' + ;; when bug#60933 is ready. + (erc-fill--make-module-dependency-msg "fill"))) + (erc-fill-mode +1)) + (when erc-fill-wrap-merge + (require 'erc-button) + (unless erc-button-mode + (unless (memq 'button erc-modules) + (setq msg (concat msg (and msg " ") + (erc-fill--make-module-dependency-msg "button")))) + (erc-with-server-buffer + (erc-button-mode +1)))) + ;; Set local value of user option (can we avoid this somehow?) + (unless (eq erc-fill-function #'erc-fill-wrap) + (setq-local erc-fill-function #'erc-fill-wrap)) + (when-let* ((vars (or erc--server-reconnecting erc--target-priors)) + ((alist-get 'erc-fill-wrap-mode vars))) + (setq erc-fill--wrap-visual-keys (alist-get 'erc-fill--wrap-visual-keys + vars) + erc-fill--wrap-value (alist-get 'erc-fill--wrap-value vars))) + (add-function :filter-args (local 'erc-stamp--insert-date-function) + #'erc-fill--wrap-stamp-insert-prefixed-date) + (when (or erc-stamp-mode (memq 'stamp erc-modules)) + (erc-stamp--display-margin-mode +1)) + (when (or (bound-and-true-p erc-match-mode) (memq 'match erc-modules)) + (require 'erc-match) + (setq erc-match--hide-fools-offset-bounds t)) + (setq erc-fill--wrap-value + (or erc-fill--wrap-value erc-fill-static-center)) + (visual-line-mode +1) + (unless (local-variable-p 'erc-fill--wrap-visual-keys) + (setq erc-fill--wrap-visual-keys erc-fill-wrap-visual-keys)) + (when msg + (erc-display-error-notice nil msg)))) + ((when erc-stamp--display-margin-mode + (erc-stamp--display-margin-mode -1)) + (kill-local-variable 'erc-fill--wrap-value) + (kill-local-variable 'erc-fill-function) + (kill-local-variable 'erc-fill--wrap-visual-keys) + (remove-function (local 'erc-stamp--insert-date-function) + #'erc-fill--wrap-stamp-insert-prefixed-date) + (visual-line-mode -1)) + 'local) + +(defvar-local erc-fill--wrap-length-function nil + "Function to determine length of overhanging characters. +It should return an EXPR as defined by the Info node `(elisp) +Pixel Specification'. This value should represent the width of +the overhang with all faces applied, including any enclosing +brackets (which are not normally fontified) and a trailing space. +It can also return nil to tell ERC to fall back to the default +behavior of taking the length from the first \"word\". This +variable can be converted to a public one if needed by third +parties.") + +(defvar-local erc-fill--wrap-last-msg nil) +(defvar-local erc-fill--wrap-max-lull (* 24 60 60)) + +(defun erc-fill--wrap-continued-message-p () + (prog1 (and-let* + ((m (or erc-fill--wrap-last-msg + (setq erc-fill--wrap-last-msg (point-min-marker)) + nil)) + ((< (1+ (point-min)) (- (point) 2))) + (props (save-restriction + (widen) + (when (eq 'erc-timestamp (field-at-pos m)) + (set-marker m (field-end m))) + (and (eq 'PRIVMSG (get-text-property m 'erc-command)) + (not (eq (get-text-property m 'font-lock-face) + 'erc-action-face)) + (cons (get-text-property m 'erc-timestamp) + (get-text-property (1+ m) 'erc-data))))) + (ts (pop props)) + ((not (time-less-p (erc-stamp--current-time) ts))) + ((time-less-p (time-subtract (erc-stamp--current-time) ts) + erc-fill--wrap-max-lull)) + (nick (buffer-substring-no-properties + (1+ (point-min)) (- (point) 2))) + ((equal (car props) (erc-downcase nick))))) + (set-marker erc-fill--wrap-last-msg (point-min)))) + +(defun erc-fill--wrap-stamp-insert-prefixed-date (args) + "Apply `line-prefix' property to args." + (let* ((ts-left (car args))) + (put-text-property 0 (length ts-left) 'line-prefix + `(space :width + (- erc-fill--wrap-value + ,(length (string-trim-left ts-left)))) + ts-left)) + args) + +(defun erc-fill-wrap () + "Use text props to mimic the effect of `erc-fill-static'. +See `erc-fill-wrap-mode' for details." + (unless erc-fill-wrap-mode + (erc-fill-wrap-mode +1)) + (save-excursion + (goto-char (point-min)) + (let ((len (or (and erc-fill--wrap-length-function + (funcall erc-fill--wrap-length-function)) + (progn + (skip-syntax-forward "^-") + (forward-char) + (cond ((and erc-fill-wrap-merge + (erc-fill--wrap-continued-message-p)) + (put-text-property (point-min) (point) + 'display "") + 0) + ((and erc-fill-wrap-use-pixels + (fboundp 'buffer-text-pixel-size)) + (save-restriction + (narrow-to-region (point-min) (point)) + (list (car (buffer-text-pixel-size))))) + (t (- (point) (point-min)))))))) + ;; Leaving out the final newline doesn't seem to affect anything. + (erc-put-text-properties (point-min) (point-max) + '(line-prefix wrap-prefix) nil + `((space :width (- erc-fill--wrap-value ,len)) + (space :width erc-fill--wrap-value)))))) + +;; This is an experimental helper for third-party modules. You could, +;; for example, use this to automatically resize the prefix to a +;; fraction of the window's width on some event change. Another use +;; case would be to fix lines affected by toggling a display-oriented +;; mode, like `display-line-numbers-mode'. + +(defun erc-fill--wrap-fix (&optional value) + "Re-wrap from `point-min' to `point-max'. +That is, recalculate the width of all accessible lines and reset +local prefix VALUE when non-nil." + (save-excursion + (when value + (setq erc-fill--wrap-value value)) + (let ((inhibit-field-text-motion t) + (inhibit-read-only t)) + (goto-char (point-min)) + (while (and (zerop (forward-line)) + (< (point) (min (point-max) erc-insert-marker))) + (save-restriction + (narrow-to-region (line-beginning-position) (line-end-position)) + (erc-fill-wrap)))))) + +(defun erc-fill--wrap-nudge (arg) + (when (zerop arg) + (setq arg (- erc-fill-static-center erc-fill--wrap-value))) + (cl-incf erc-fill--wrap-value arg) + arg) + +(defun erc-fill-wrap-nudge (arg) + "Adjust `erc-fill-wrap' by ARG columns. +Offer to repeat command in a manner similar to +`text-scale-adjust'. + + \\`=' Increase indentation by one column + \\`-' Decrease indentation by one column + \\`0' Reset indentation to the default + \\`+' Shift right margin rightward (shrink) by one column + \\`_' Shift right margin leftward (grow) by one column + \\`)' Reset the right margin to the default + +Note that misalignment may occur when messages contain +decorations applied by third-party modules. See +`erc-fill--wrap-fix' for a temporary workaround." + (interactive "p") + (unless erc-fill--wrap-value + (cl-assert (not erc-fill-wrap-mode)) + (user-error "Minor mode `erc-fill-wrap-mode' disabled")) + (unless (get-buffer-window) + (user-error "Command called in an undisplayed buffer")) + (let* ((total (erc-fill--wrap-nudge arg)) + (win-ratio (/ (float (- (window-point) (window-start))) + (- (window-end nil t) (window-start))))) + (when (zerop arg) + (setq arg 1)) + (erc-compat-call + set-transient-map + (let ((map (make-sparse-keymap))) + (dolist (key '(?= ?- ?0)) + (let ((a (pcase key + (?0 0) + (?- (- (abs arg))) + (_ (abs arg))))) + (define-key map (vector (list key)) + (lambda () + (interactive) + (cl-incf total (erc-fill--wrap-nudge a)) + (recenter (round (* win-ratio (window-height)))))))) + (dolist (key '(?\) ?_ ?+)) + (let ((a (pcase key + (?\) 0) + (?_ (- (abs arg))) + (?+ (abs arg))))) + (define-key map (vector (list key)) + (lambda () + (interactive) + (erc-stamp--adjust-right-margin (- a)) + (recenter (round (* win-ratio (window-height)))))))) + map) + t + (lambda () + (message "Fill prefix: %d (%+d col%s)" + erc-fill--wrap-value total (if (> (abs total) 1) "s" ""))) + "Use %k for further adjustment" + 1) + (recenter (round (* win-ratio (window-height)))))) + (defun erc-fill-regarding-timestamp () "Fills a text such that messages start at column `erc-fill-static-center'." (fill-region (point-min) (point-max) t t) diff --git a/test/lisp/erc/erc-fill-tests.el b/test/lisp/erc/erc-fill-tests.el new file mode 100644 index 00000000000..f249be8fb86 --- /dev/null +++ b/test/lisp/erc/erc-fill-tests.el @@ -0,0 +1,313 @@ +;;; erc-fill-tests.el --- Tests for erc-fill -*- lexical-binding:t -*- + +;; Copyright (C) 2023 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: + +;; FIXME these tests are brittle and error prone. Replace with +;; scenarios. + +;;; Code: +(require 'ert-x) +(require 'erc-fill) + +(defvar erc-fill-tests--buffers nil) +(defvar erc-fill-tests--time-vals (lambda () 0)) + +(defun erc-fill-tests--insert-privmsg (speaker &rest msg-parts) + (declare (indent 1)) + (let ((msg (erc-format-privmessage speaker + (apply #'concat msg-parts) nil t))) + (put-text-property 0 (length msg) 'erc-command 'PRIVMSG msg) + (erc-display-message nil nil (current-buffer) msg))) + +(defun erc-fill-tests--wrap-populate (test) + (let ((original-window-buffer (window-buffer (selected-window))) + (erc-stamp--tz t) + (erc-fill-function 'erc-fill-wrap) + (pre-command-hook pre-command-hook) + (inhibit-message noninteractive) + erc-insert-post-hook + extended-command-history + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + (cl-letf (((symbol-function 'erc-stamp--current-time) + (lambda () (funcall erc-fill-tests--time-vals))) + ((symbol-function 'erc-server-connect) + (lambda (&rest _) + (setq erc-server-process + (start-process "sleep" (current-buffer) "sleep" "1")) + (set-process-query-on-exit-flag erc-server-process nil)))) + (with-current-buffer + (car (push (erc-open "localhost" 6667 "tester" "Tester" 'connect + nil nil nil nil nil "tester" 'foonet) + erc-fill-tests--buffers)) + (setq erc-network 'foonet + erc-server-connected t) + (with-current-buffer (erc--open-target "#chan") + (set-window-buffer (selected-window) (current-buffer)) + + (erc-update-channel-member + "#chan" "alice" "alice" t nil nil nil nil nil "fake" "~u" nil nil t) + + (erc-update-channel-member + "#chan" "bob" "bob" t nil nil nil nil nil "fake" "~u" nil nil t) + + (erc-display-message + nil 'notice (current-buffer) + (concat "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.")) + + (erc-fill-tests--insert-privmsg "alice" + "bob: 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.") + + ;; Introduce an artificial gap in properties `line-prefix' and + ;; `wrap-prefix' and later ensure they're not incremented twice. + (save-excursion + (forward-line -1) + (search-forward "? ") + (with-silent-modifications + (remove-text-properties (1- (point)) (point) + '(line-prefix t wrap-prefix t)))) + + (erc-fill-tests--insert-privmsg "bob" + "alice: Either your unparagoned mistress is dead, " + "or she's outprized by a trifle.") + + ;; Defend against non-local exits from `ert-skip' + (unwind-protect + (funcall test) + (set-window-buffer (selected-window) original-window-buffer) + (when noninteractive + (while-let ((buf (pop erc-fill-tests--buffers))) + (kill-buffer buf)) + (kill-buffer)))))))) + +(defun erc-fill-tests--wrap-check-prefixes (&rest prefixes) + ;; Check that prefix props are applied over correct intervals. + (save-excursion + (goto-char (point-min)) + (dolist (prefix prefixes) + (should (search-forward prefix nil t)) + (should (get-text-property (pos-bol) 'line-prefix)) + (should (get-text-property (pos-eol) 'line-prefix)) + (should (equal (get-text-property (pos-bol) 'wrap-prefix) + '(space :width erc-fill--wrap-value))) + (should (equal (get-text-property (pos-eol) 'wrap-prefix) + '(space :width erc-fill--wrap-value)))))) + +;; Set this variable to t to generate new snapshots after carefully +;; reviewing the output of *each* snapshot (not just first and last). +;; Obviously, only run one test at a time. +(defvar erc-fill-tests--save-p nil) + +(defun erc-fill-tests--compare (name) + (when (display-graphic-p) + (setq name (concat name "-graphic"))) + (let* ((dir (expand-file-name "fill/snapshots/" (ert-resource-directory))) + (expect-file (file-name-with-extension (expand-file-name name dir) + "eld")) + (erc--own-property-names + (seq-difference `(font-lock-face ,@erc--own-property-names) + '(field display wrap-prefix line-prefix) + #'eq)) + (print-circle t) + (print-escape-newlines t) + (print-escape-nonascii t) + (got (erc--remove-text-properties + (buffer-substring (point-min) erc-insert-marker))) + (repr (string-replace "erc-fill--wrap-value" + (number-to-string erc-fill--wrap-value) + (prin1-to-string got)))) + (with-current-buffer (generate-new-buffer name) + (push name erc-fill-tests--buffers) + (with-silent-modifications + (insert (setq got (read repr)))) + (erc-mode)) + (if erc-fill-tests--save-p + (with-temp-file expect-file + (insert repr)) + (if (file-exists-p expect-file) + ;; Compare set-equal over intervals + (should (equal-including-properties + (read repr) + (read (with-temp-buffer + (insert-file-contents-literally expect-file) + (buffer-string))))) + (message "Snapshot file missing: %S" expect-file))))) + +;; To inspect variable pitch, set `erc-mode-hook' to +;; +;; (lambda () (face-remap-add-relative 'default :family "Sans Serif")) +;; +;; or similar. + +(ert-deftest erc-fill-wrap--monospace () + :tags '(:unstable) + (unless (>= emacs-major-version 29) + (ert-skip "Emacs version too low, missing `buffer-text-pixel-size'")) + + (erc-fill-tests--wrap-populate + + (lambda () + (should (= erc-fill--wrap-value 27)) + (erc-fill-tests--wrap-check-prefixes "*** " " " " ") + (erc-fill-tests--compare "monospace-01-start") + + (ert-info ("Shift right by one (plus)") + ;; Args are all `erc-fill-wrap-nudge' +1 because interactive "p" + (ert-with-message-capture messages + ;; M-x erc-fill-wrap-nudge RET = + (ert-simulate-command '(erc-fill-wrap-nudge 2)) + (should (string-match (rx "for further adjustment") messages))) + (should (= erc-fill--wrap-value 29)) + (erc-fill-tests--wrap-check-prefixes "*** " " " " ") + (erc-fill-tests--compare "monospace-02-right")) + + (ert-info ("Shift left by five") + ;; "M-x erc-fill-wrap-nudge RET -----" + (ert-simulate-command '(erc-fill-wrap-nudge -4)) + (should (= erc-fill--wrap-value 25)) + (erc-fill-tests--wrap-check-prefixes "*** " " " " ") + (erc-fill-tests--compare "monospace-03-left")) + + (ert-info ("Reset") + ;; M-x erc-fill-wrap-nudge RET 0 + (ert-simulate-command '(erc-fill-wrap-nudge 0)) + (should (= erc-fill--wrap-value 27)) + (erc-fill-tests--wrap-check-prefixes "*** " " " " ") + (erc-fill-tests--compare "monospace-04-reset"))))) + +(ert-deftest erc-fill-wrap--merge () + :tags '(:unstable) + (unless (>= emacs-major-version 29) + (ert-skip "Emacs version too low, missing `buffer-text-pixel-size'")) + + (erc-fill-tests--wrap-populate + + (lambda () + ;; Set this here so that the first few messages are from 1970 + (let ((erc-fill-tests--time-vals (lambda () 1680332400))) + (erc-fill-tests--insert-privmsg "bob" "zero.") + (erc-fill-tests--insert-privmsg "alice" "one.") + (erc-fill-tests--insert-privmsg "alice" "two.") + (erc-fill-tests--insert-privmsg "bob" "three.") + (erc-fill-tests--insert-privmsg "bob" "four.")) + + (should (= erc-fill--wrap-value 27)) + (erc-fill-tests--wrap-check-prefixes + "*** " " " " " + " " " " " " " " " ") + (erc-fill-tests--compare "merge-01-start") + + (ert-info ("Shift right by one (plus)") + (ert-simulate-command '(erc-fill-wrap-nudge 2)) + (should (= erc-fill--wrap-value 29)) + (erc-fill-tests--wrap-check-prefixes + "*** " " " " " + " " " " " " " " " ") + (erc-fill-tests--compare "merge-02-right"))))) + +(ert-deftest erc-fill-wrap-visual-keys--body () + :tags '(:unstable) + (erc-fill-tests--wrap-populate + + (lambda () + (ert-info ("Value: non-input") + (should (eq erc-fill--wrap-visual-keys 'non-input)) + (goto-char (point-min)) + (should (search-forward "that he hath" nil t)) + (execute-kbd-macro "\C-a") + (should-not (looking-at (rx " "))) + (execute-kbd-macro "\C-e") + (should (search-backward "tedious fool" nil t)) + (should-not (looking-back "done to her\\.")) + (forward-char) + (execute-kbd-macro "\C-e") + (should (search-forward "done to her." nil t))) + + (ert-info ("Value: nil") + (execute-kbd-macro "\C-ca") + (should-not erc-fill--wrap-visual-keys) + (goto-char (point-min)) + (should (search-forward "in debug mode" nil t)) + (execute-kbd-macro "\C-a") + (should (looking-at (rx "*** "))) + (execute-kbd-macro "\C-e") + (should (eql ?\] (char-before (point))))) + + (ert-info ("Value: t") + (execute-kbd-macro "\C-ca") + (should (eq erc-fill--wrap-visual-keys t)) + (goto-char (point-min)) + (should (search-forward "that he hath" nil t)) + (execute-kbd-macro "\C-a") + (should-not (looking-at (rx " "))) + (should (search-backward "tedious fool" nil t)) + (execute-kbd-macro "\C-e") + (should-not (looking-back (rx "done to her\\."))) + (should (search-forward "done to her." nil t)) + (execute-kbd-macro "\C-a") + (should-not (looking-at (rx " "))))))) + +(ert-deftest erc-fill-wrap-visual-keys--prompt () + :tags '(:unstable) + (erc-fill-tests--wrap-populate + + (lambda () + (set-window-buffer (selected-window) (current-buffer)) + (goto-char erc-input-marker) + (insert "This buffer is for text that is not saved, and for Lisp " + "evaluation. To create a file, visit it with C-x C-f and " + "enter text in its buffer.") + + (ert-info ("Value: non-input") + (should (eq erc-fill--wrap-visual-keys 'non-input)) + (execute-kbd-macro "\C-a") + (should (looking-at "This buffer")) + (execute-kbd-macro "\C-e") + (should (looking-back "its buffer\\.")) + (execute-kbd-macro "\C-a") + (execute-kbd-macro "\C-k") + (should (eobp))) + + (ert-info ("Value: nil") ; same + (execute-kbd-macro "\C-ca") + (should-not erc-fill--wrap-visual-keys) + (execute-kbd-macro "\C-y") + (should (looking-back "its buffer\\.")) + (execute-kbd-macro "\C-a") + (should (looking-at "This buffer")) + (execute-kbd-macro "\C-k") + (should (eobp))) + + (ert-info ("Value: non-input") + (execute-kbd-macro "\C-ca") + (should (eq erc-fill--wrap-visual-keys t)) + (execute-kbd-macro "\C-y") + (execute-kbd-macro "\C-a") + (should-not (looking-at "This buffer")) + (execute-kbd-macro "\C-p") + (should-not (looking-back "its buffer\\.")) + (should (search-forward "its buffer." nil t)) + (should (search-backward "ERC> " nil t)) + (execute-kbd-macro "\C-a"))))) + +;;; erc-fill-tests.el ends here diff --git a/test/lisp/erc/resources/fill/snapshots/merge-01-start.eld b/test/lisp/erc/resources/fill/snapshots/merge-01-start.eld new file mode 100644 index 00000000000..db3136a9d9e --- /dev/null +++ b/test/lisp/erc/resources/fill/snapshots/merge-01-start.eld @@ -0,0 +1 @@ +#("\n\n\n[Thu Jan 1 1970]\n*** 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.[00:00]\n bob: 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.\n alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n zero.[07:00]\n one.\n two.\n three.\n four.\n" 2 21 (erc-timestamp 0 line-prefix (space :width (- 27 18)) field erc-timestamp) 21 183 (erc-timestamp 0 wrap-prefix #2=(space :width 27) line-prefix #3=(space :width (- 27 (4)))) 183 190 (erc-timestamp 0 field erc-timestamp wrap-prefix #2# line-prefix #3# display #1=(#6=(margin right-margin) #("[00:00]" 0 7 (display #1# isearch-open-invisible timestamp invisible timestamp font-lock-face erc-timestamp-face)))) 190 191 (wrap-prefix #2# line-prefix #3#) 191 192 (erc-timestamp 0 wrap-prefix #2# line-prefix #4=(space :width (- 27 (8))) erc-command PRIVMSG) 192 197 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 197 199 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 199 202 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 202 315 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 315 316 (erc-timestamp 0 erc-command PRIVMSG) 316 348 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 348 349 (wrap-prefix #2# line-prefix #4#) 349 350 (erc-timestamp 0 wrap-prefix #2# line-prefix #5=(space :width (- 27 (6))) erc-command PRIVMSG) 350 353 (erc-timestamp 0 wrap-prefix #2# line-prefix #5# erc-command PRIVMSG) 353 355 (erc-timestamp 0 wrap-prefix #2# line-prefix #5# erc-command PRIVMSG) 355 360 (erc-timestamp 0 wrap-prefix #2# line-prefix #5# erc-command PRIVMSG) 360 435 (erc-timestamp 0 wrap-prefix #2# line-prefix #5# erc-command PRIVMSG) 435 436 (wrap-prefix #2# line-prefix #5#) 436 455 (erc-timestamp 1680332400 line-prefix (space :width (- 27 18)) field erc-timestamp) 455 456 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #8=(space :width (- 27 (6))) erc-command PRIVMSG) 456 459 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #8# erc-command PRIVMSG) 459 466 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #8# erc-command PRIVMSG) 466 473 (erc-timestamp 1680332400 field erc-timestamp wrap-prefix #2# line-prefix #8# display #7=(#6# #("[07:00]" 0 7 (display #7# isearch-open-invisible timestamp invisible timestamp font-lock-face erc-timestamp-face)))) 473 474 (wrap-prefix #2# line-prefix #8#) 474 475 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #9=(space :width (- 27 (8))) erc-command PRIVMSG) 475 480 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #9# erc-command PRIVMSG) 480 486 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #9# erc-command PRIVMSG) 486 487 (wrap-prefix #2# line-prefix #9#) 487 488 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #10=(space :width (- 27 0)) display #11="" erc-command PRIVMSG) 488 493 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #10# display #11# erc-command PRIVMSG) 493 495 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #10# display #11# erc-command PRIVMSG) 495 499 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #10# erc-command PRIVMSG) 499 500 (wrap-prefix #2# line-prefix #10#) 500 501 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #12=(space :width (- 27 (6))) erc-command PRIVMSG) 501 504 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #12# erc-command PRIVMSG) 504 512 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #12# erc-command PRIVMSG) 512 513 (wrap-prefix #2# line-prefix #12#) 513 514 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #13=(space :width (- 27 0)) display #11# erc-command PRIVMSG) 514 517 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #13# display #11# erc-command PRIVMSG) 517 519 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #13# display #11# erc-command PRIVMSG) 519 524 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #13# erc-command PRIVMSG) 524 525 (wrap-prefix #2# line-prefix #13#)) \ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/merge-02-right.eld b/test/lisp/erc/resources/fill/snapshots/merge-02-right.eld new file mode 100644 index 00000000000..fcb9e59b757 --- /dev/null +++ b/test/lisp/erc/resources/fill/snapshots/merge-02-right.eld @@ -0,0 +1 @@ +#("\n\n\n[Thu Jan 1 1970]\n*** 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.[00:00]\n bob: 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.\n alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n\n[Sat Apr 1 2023]\n zero.[07:00]\n one.\n two.\n three.\n four.\n" 2 21 (erc-timestamp 0 line-prefix (space :width (- 29 18)) field erc-timestamp) 21 183 (erc-timestamp 0 wrap-prefix #2=(space :width 29) line-prefix #3=(space :width (- 29 (4)))) 183 190 (erc-timestamp 0 field erc-timestamp wrap-prefix #2# line-prefix #3# display #1=(#6=(margin right-margin) #("[00:00]" 0 7 (display #1# isearch-open-invisible timestamp invisible timestamp font-lock-face erc-timestamp-face)))) 190 191 (wrap-prefix #2# line-prefix #3#) 191 192 (erc-timestamp 0 wrap-prefix #2# line-prefix #4=(space :width (- 29 (8))) erc-command PRIVMSG) 192 197 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 197 199 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 199 202 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 202 315 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 315 316 (erc-timestamp 0 erc-command PRIVMSG) 316 348 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 348 349 (wrap-prefix #2# line-prefix #4#) 349 350 (erc-timestamp 0 wrap-prefix #2# line-prefix #5=(space :width (- 29 (6))) erc-command PRIVMSG) 350 353 (erc-timestamp 0 wrap-prefix #2# line-prefix #5# erc-command PRIVMSG) 353 355 (erc-timestamp 0 wrap-prefix #2# line-prefix #5# erc-command PRIVMSG) 355 360 (erc-timestamp 0 wrap-prefix #2# line-prefix #5# erc-command PRIVMSG) 360 435 (erc-timestamp 0 wrap-prefix #2# line-prefix #5# erc-command PRIVMSG) 435 436 (wrap-prefix #2# line-prefix #5#) 436 455 (erc-timestamp 1680332400 line-prefix (space :width (- 29 18)) field erc-timestamp) 455 456 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #8=(space :width (- 29 (6))) erc-command PRIVMSG) 456 459 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #8# erc-command PRIVMSG) 459 466 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #8# erc-command PRIVMSG) 466 473 (erc-timestamp 1680332400 field erc-timestamp wrap-prefix #2# line-prefix #8# display #7=(#6# #("[07:00]" 0 7 (display #7# isearch-open-invisible timestamp invisible timestamp font-lock-face erc-timestamp-face)))) 473 474 (wrap-prefix #2# line-prefix #8#) 474 475 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #9=(space :width (- 29 (8))) erc-command PRIVMSG) 475 480 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #9# erc-command PRIVMSG) 480 486 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #9# erc-command PRIVMSG) 486 487 (wrap-prefix #2# line-prefix #9#) 487 488 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #10=(space :width (- 29 0)) display #11="" erc-command PRIVMSG) 488 493 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #10# display #11# erc-command PRIVMSG) 493 495 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #10# display #11# erc-command PRIVMSG) 495 499 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #10# erc-command PRIVMSG) 499 500 (wrap-prefix #2# line-prefix #10#) 500 501 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #12=(space :width (- 29 (6))) erc-command PRIVMSG) 501 504 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #12# erc-command PRIVMSG) 504 512 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #12# erc-command PRIVMSG) 512 513 (wrap-prefix #2# line-prefix #12#) 513 514 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #13=(space :width (- 29 0)) display #11# erc-command PRIVMSG) 514 517 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #13# display #11# erc-command PRIVMSG) 517 519 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #13# display #11# erc-command PRIVMSG) 519 524 (erc-timestamp 1680332400 wrap-prefix #2# line-prefix #13# erc-command PRIVMSG) 524 525 (wrap-prefix #2# line-prefix #13#)) \ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/monospace-01-start.eld b/test/lisp/erc/resources/fill/snapshots/monospace-01-start.eld new file mode 100644 index 00000000000..67ebad542fb --- /dev/null +++ b/test/lisp/erc/resources/fill/snapshots/monospace-01-start.eld @@ -0,0 +1 @@ +#("\n\n\n[Thu Jan 1 1970]\n*** 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.[00:00]\n bob: 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.\n alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n" 2 21 (erc-timestamp 0 line-prefix (space :width (- 27 18)) field erc-timestamp) 21 183 (erc-timestamp 0 wrap-prefix #2=(space :width 27) line-prefix #3=(space :width (- 27 (4)))) 183 190 (erc-timestamp 0 field erc-timestamp wrap-prefix #2# line-prefix #3# display #1=((margin right-margin) #("[00:00]" 0 7 (display #1# isearch-open-invisible timestamp invisible timestamp font-lock-face erc-timestamp-face)))) 190 191 (wrap-prefix #2# line-prefix #3#) 191 192 (erc-timestamp 0 wrap-prefix #2# line-prefix #4=(space :width (- 27 (8))) erc-command PRIVMSG) 192 197 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 197 199 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 199 202 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 202 315 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 315 316 (erc-timestamp 0 erc-command PRIVMSG) 316 348 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 348 349 (wrap-prefix #2# line-prefix #4#) 349 350 (erc-timestamp 0 wrap-prefix #2# line-prefix #5=(space :width (- 27 (6))) erc-command PRIVMSG) 350 353 (erc-timestamp 0 wrap-prefix #2# line-prefix #5# erc-command PRIVMSG) 353 355 (erc-timestamp 0 wrap-prefix #2# line-prefix #5# erc-command PRIVMSG) 355 360 (erc-timestamp 0 wrap-prefix #2# line-prefix #5# erc-command PRIVMSG) 360 435 (erc-timestamp 0 wrap-prefix #2# line-prefix #5# erc-command PRIVMSG) 435 436 (wrap-prefix #2# line-prefix #5#)) \ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/monospace-02-right.eld b/test/lisp/erc/resources/fill/snapshots/monospace-02-right.eld new file mode 100644 index 00000000000..0bf8001475d --- /dev/null +++ b/test/lisp/erc/resources/fill/snapshots/monospace-02-right.eld @@ -0,0 +1 @@ +#("\n\n\n[Thu Jan 1 1970]\n*** 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.[00:00]\n bob: 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.\n alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n" 2 21 (erc-timestamp 0 line-prefix (space :width (- 29 18)) field erc-timestamp) 21 183 (erc-timestamp 0 wrap-prefix #2=(space :width 29) line-prefix #3=(space :width (- 29 (4)))) 183 190 (erc-timestamp 0 field erc-timestamp wrap-prefix #2# line-prefix #3# display #1=((margin right-margin) #("[00:00]" 0 7 (display #1# isearch-open-invisible timestamp invisible timestamp font-lock-face erc-timestamp-face)))) 190 191 (wrap-prefix #2# line-prefix #3#) 191 192 (erc-timestamp 0 wrap-prefix #2# line-prefix #4=(space :width (- 29 (8))) erc-command PRIVMSG) 192 197 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 197 199 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 199 202 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 202 315 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 315 316 (erc-timestamp 0 erc-command PRIVMSG) 316 348 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 348 349 (wrap-prefix #2# line-prefix #4#) 349 350 (erc-timestamp 0 wrap-prefix #2# line-prefix #5=(space :width (- 29 (6))) erc-command PRIVMSG) 350 353 (erc-timestamp 0 wrap-prefix #2# line-prefix #5# erc-command PRIVMSG) 353 355 (erc-timestamp 0 wrap-prefix #2# line-prefix #5# erc-command PRIVMSG) 355 360 (erc-timestamp 0 wrap-prefix #2# line-prefix #5# erc-command PRIVMSG) 360 435 (erc-timestamp 0 wrap-prefix #2# line-prefix #5# erc-command PRIVMSG) 435 436 (wrap-prefix #2# line-prefix #5#)) \ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/monospace-03-left.eld b/test/lisp/erc/resources/fill/snapshots/monospace-03-left.eld new file mode 100644 index 00000000000..7d231d19cef --- /dev/null +++ b/test/lisp/erc/resources/fill/snapshots/monospace-03-left.eld @@ -0,0 +1 @@ +#("\n\n\n[Thu Jan 1 1970]\n*** 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.[00:00]\n bob: 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.\n alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n" 2 21 (erc-timestamp 0 line-prefix (space :width (- 25 18)) field erc-timestamp) 21 183 (erc-timestamp 0 wrap-prefix #2=(space :width 25) line-prefix #3=(space :width (- 25 (4)))) 183 190 (erc-timestamp 0 field erc-timestamp wrap-prefix #2# line-prefix #3# display #1=((margin right-margin) #("[00:00]" 0 7 (display #1# isearch-open-invisible timestamp invisible timestamp font-lock-face erc-timestamp-face)))) 190 191 (wrap-prefix #2# line-prefix #3#) 191 192 (erc-timestamp 0 wrap-prefix #2# line-prefix #4=(space :width (- 25 (8))) erc-command PRIVMSG) 192 197 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 197 199 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 199 202 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 202 315 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 315 316 (erc-timestamp 0 erc-command PRIVMSG) 316 348 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 348 349 (wrap-prefix #2# line-prefix #4#) 349 350 (erc-timestamp 0 wrap-prefix #2# line-prefix #5=(space :width (- 25 (6))) erc-command PRIVMSG) 350 353 (erc-timestamp 0 wrap-prefix #2# line-prefix #5# erc-command PRIVMSG) 353 355 (erc-timestamp 0 wrap-prefix #2# line-prefix #5# erc-command PRIVMSG) 355 360 (erc-timestamp 0 wrap-prefix #2# line-prefix #5# erc-command PRIVMSG) 360 435 (erc-timestamp 0 wrap-prefix #2# line-prefix #5# erc-command PRIVMSG) 435 436 (wrap-prefix #2# line-prefix #5#)) \ No newline at end of file diff --git a/test/lisp/erc/resources/fill/snapshots/monospace-04-reset.eld b/test/lisp/erc/resources/fill/snapshots/monospace-04-reset.eld new file mode 100644 index 00000000000..67ebad542fb --- /dev/null +++ b/test/lisp/erc/resources/fill/snapshots/monospace-04-reset.eld @@ -0,0 +1 @@ +#("\n\n\n[Thu Jan 1 1970]\n*** 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.[00:00]\n bob: 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.\n alice: Either your unparagoned mistress is dead, or she's outprized by a trifle.\n" 2 21 (erc-timestamp 0 line-prefix (space :width (- 27 18)) field erc-timestamp) 21 183 (erc-timestamp 0 wrap-prefix #2=(space :width 27) line-prefix #3=(space :width (- 27 (4)))) 183 190 (erc-timestamp 0 field erc-timestamp wrap-prefix #2# line-prefix #3# display #1=((margin right-margin) #("[00:00]" 0 7 (display #1# isearch-open-invisible timestamp invisible timestamp font-lock-face erc-timestamp-face)))) 190 191 (wrap-prefix #2# line-prefix #3#) 191 192 (erc-timestamp 0 wrap-prefix #2# line-prefix #4=(space :width (- 27 (8))) erc-command PRIVMSG) 192 197 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 197 199 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 199 202 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 202 315 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 315 316 (erc-timestamp 0 erc-command PRIVMSG) 316 348 (erc-timestamp 0 wrap-prefix #2# line-prefix #4# erc-command PRIVMSG) 348 349 (wrap-prefix #2# line-prefix #4#) 349 350 (erc-timestamp 0 wrap-prefix #2# line-prefix #5=(space :width (- 27 (6))) erc-command PRIVMSG) 350 353 (erc-timestamp 0 wrap-prefix #2# line-prefix #5# erc-command PRIVMSG) 353 355 (erc-timestamp 0 wrap-prefix #2# line-prefix #5# erc-command PRIVMSG) 355 360 (erc-timestamp 0 wrap-prefix #2# line-prefix #5# erc-command PRIVMSG) 360 435 (erc-timestamp 0 wrap-prefix #2# line-prefix #5# erc-command PRIVMSG) 435 436 (wrap-prefix #2# line-prefix #5#)) \ No newline at end of file commit e3c4a648d166600fa507caaca3efbbc7f9a6d12f Author: F. Jason Park Date: Fri Jan 27 05:34:56 2023 -0800 Add variant for erc-match invisibility spec * lisp/erc/erc-match.el (erc-match-mode, erc-match-enable, erc-match-disable): Arrange for possibly adding or removing `erc-match' from `buffer-invisibility-spec'. (erc-match--hide-fools-offset-bounds): Add new variable to serve as switch for activating invisibility on a modified interval that's offset toward `point-min' by one character. (erc-hide-fools): Optionally offset start and end of invisible region by minus one. (erc-match--modify-invisibility-spec): New housekeeping function to set up and tear down offset spec. (Bug#60936.) diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el index 7ec9078d493..82b821503a8 100644 --- a/lisp/erc/erc-match.el +++ b/lisp/erc/erc-match.el @@ -53,8 +53,11 @@ match you can decide whether the entire message or only the sending nick is highlighted." ((add-hook 'erc-insert-modify-hook #'erc-match-message 'append) + (add-hook 'erc-mode-hook #'erc-match--modify-invisibility-spec) (erc--modify-local-map t "C-c C-k" #'erc-go-to-log-matches-buffer)) ((remove-hook 'erc-insert-modify-hook #'erc-match-message) + (remove-hook 'erc-mode-hook #'erc-match--modify-invisibility-spec) + (erc-match--modify-invisibility-spec) (erc--modify-local-map nil "C-c C-k" #'erc-go-to-log-matches-buffer))) ;; Remaining customizations @@ -649,13 +652,22 @@ erc-go-to-log-matches-buffer (get-buffer (car buffer-cons)))))) (switch-to-buffer buffer-name))) +(defvar-local erc-match--hide-fools-offset-bounds nil) + (defun erc-hide-fools (match-type _nickuserhost _message) "Hide foolish comments. This function should be called from `erc-text-matched-hook'." - (when (eq match-type 'fool) - (erc-put-text-properties (point-min) (point-max) - '(invisible intangible) - (current-buffer)))) + (when (eq match-type 'fool) + (if erc-match--hide-fools-offset-bounds + (let ((beg (point-min)) + (end (point-max))) + (save-restriction + (widen) + (put-text-property (1- beg) (1- end) 'invisible 'erc-match))) + ;; The docs say `intangible' is deprecated, but this has been + ;; like this for ages. Should verify unneeded and remove if so. + (erc-put-text-properties (point-min) (point-max) + '(invisible intangible))))) (defun erc-beep-on-match (match-type _nickuserhost _message) "Beep when text matches. @@ -663,6 +675,13 @@ erc-beep-on-match (when (member match-type erc-beep-match-types) (beep))) +(defun erc-match--modify-invisibility-spec () + "Add an ellipsis property to the local spec." + (if erc-match-mode + (add-to-invisibility-spec 'erc-match) + (erc-with-all-buffers-of-server nil nil + (remove-from-invisibility-spec 'erc-match)))) + (provide 'erc-match) ;;; erc-match.el ends here commit 0c3a069ae0051148f2f35f542ce4ef573e5f5468 Author: F. Jason Park Date: Sun Apr 24 02:38:12 2022 -0700 Convert erc-fill minor mode into a proper module * lisp/erc/erc-fill.el (erc-fill-mode, erc-fill-enable, erc-fill-disable): Use API to create these. (erc-fill-static): Save restriction instead of caller's match data. (Bug#60936.) diff --git a/lisp/erc/erc-fill.el b/lisp/erc/erc-fill.el index e10b7d790f6..caf401bf222 100644 --- a/lisp/erc/erc-fill.el +++ b/lisp/erc/erc-fill.el @@ -38,30 +38,18 @@ erc-fill :group 'erc) ;;;###autoload(autoload 'erc-fill-mode "erc-fill" nil t) -(define-minor-mode erc-fill-mode - "Toggle ERC fill mode. -With a prefix argument ARG, enable ERC fill mode if ARG is -positive, and disable it otherwise. If called from Lisp, enable -the mode if ARG is omitted or nil. - +(define-erc-module fill nil + "Manage filling in ERC buffers. ERC fill mode is a global minor mode. When enabled, messages in the channel buffers are filled." - :global t - (if erc-fill-mode - (erc-fill-enable) - (erc-fill-disable))) - -(defun erc-fill-enable () - "Setup hooks for `erc-fill-mode'." - (interactive) - (add-hook 'erc-insert-modify-hook #'erc-fill) - (add-hook 'erc-send-modify-hook #'erc-fill)) - -(defun erc-fill-disable () - "Cleanup hooks, disable `erc-fill-mode'." - (interactive) - (remove-hook 'erc-insert-modify-hook #'erc-fill) - (remove-hook 'erc-send-modify-hook #'erc-fill)) + ;; FIXME ensure a consistent ordering relative to hook members from + ;; other modules. Ideally, this module's processing should happen + ;; after "morphological" modifications to a message's text but + ;; before superficial decorations. + ((add-hook 'erc-insert-modify-hook #'erc-fill) + (add-hook 'erc-send-modify-hook #'erc-fill)) + ((remove-hook 'erc-insert-modify-hook #'erc-fill) + (remove-hook 'erc-send-modify-hook #'erc-fill))) (defcustom erc-fill-prefix nil "Values used as `fill-prefix' for `erc-fill-variable'. @@ -130,7 +118,7 @@ erc-fill (defun erc-fill-static () "Fills a text such that messages start at column `erc-fill-static-center'." - (save-match-data + (save-restriction (goto-char (point-min)) (looking-at "^\\(\\S-+\\)") (let ((nick (match-string 1))) commit 9f6a9cef97b118d3a6685dfd804332541f9838a3 Author: F. Jason Park Date: Wed Nov 24 05:35:35 2021 -0800 Put display properties to better use in erc-stamp * lisp/erc/erc-log.el (erc-log-filter-function): Add new value `erc-stamp-prefix-log-filter'. * lisp/erc/erc-stamp.el (erc-timestamp-use-align-to): Enhance meaning of option to accept numeric value for dynamically aligned right-hand stamps. Use `graphic-display-p' to determine default value even though, as stated in the manual, terminal Emacs also supports the "space" display spec. (erc-stamp-right-margin-width): New option to determine width of right margin when `erc-stamp--display-margin-mode' is active or `erc-timestamp-use-align-to' is set to `margin'. (erc-stamp--display-margin-force): Add new helper function for `erc-stamp--display-margin-mode'. (erc-stamp--adjust-right-margin): New function to adjust width of right margin. (erc-stamp-prefix-log-filter): New value for `erc-log-filter-function' compatible with modules that activate `erc-stamp--display-margin-mode'. (erc-stamp--display-margin-mode): Add internal minor mode to help other modules quickly ensure left-right, display-prop-oriented stamps are showing correctly. Does not support left-hand-only stamps. (erc-insert-aligned): Deprecate function and remove from primary client code path. (erc-stamp--inherited-props): Add internal constant to hold properties that should be inherited from any stamp-bearing message being inserted. (erc-insert-timestamp-right): Account for new display-related values of `erc-timestamp-use-align-to'. * test/lisp/erc/erc-stamp-tests.el (erc-timestamp-use-align-to--nil, erc-timestamp-use-align-to--t): Adjust spacing for new default right-hand stamp, `erc-format-timestamp', which lacks a leading space. (erc-timestamp-use-align-to--integer, erc-timestamp-use-align-to--margin): New tests. (Bug#60936.) diff --git a/lisp/erc/erc-log.el b/lisp/erc/erc-log.el index a44437ddcf7..2b58a7c56ed 100644 --- a/lisp/erc/erc-log.el +++ b/lisp/erc/erc-log.el @@ -198,6 +198,7 @@ erc-log-filter-function The function should take one argument, which is the text to filter." :type '(choice (function "Function") + (function-item erc-stamp-prefix-log-filter) (const :tag "No filtering" nil))) diff --git a/lisp/erc/erc-stamp.el b/lisp/erc/erc-stamp.el index 18371320300..8bca9bdb56b 100644 --- a/lisp/erc/erc-stamp.el +++ b/lisp/erc/erc-stamp.el @@ -253,14 +253,110 @@ erc-timestamp-right-column (integer :tag "Column number") (const :tag "Unspecified" nil))) -(defcustom erc-timestamp-use-align-to (eq window-system 'x) +(defcustom erc-timestamp-use-align-to (and (display-graphic-p) t) "If non-nil, use the :align-to display property to align the stamp. This gives better results when variable-width characters (like Asian language characters and math symbols) precede a timestamp. -A side effect of enabling this is that there will only be one -space before a right timestamp in any saved logs." - :type 'boolean) +This option only matters when `erc-insert-timestamp-function' is +set to `erc-insert-timestamp-right' or that option's default, +`erc-insert-timestamp-left-and-right'. If the value is a +positive integer, alignment occurs that many columns from the +right edge. If the value is `margin', the stamp appears in the +right margin when visible. + +Enabling this option produces a side effect in that stamps aren't +indented in saved logs. When its value is an integer, this +option adds a space after the end of a message if the stamp +doesn't already start with one. And when its value is t, it adds +a single space, unconditionally. And while this option never +adds a space when its value is `margin', ERC does offer a +workaround in `erc-stamp-prefix-log-filter', which strips +trailing stamps from messages and puts them before every line." + :type '(choice boolean integer (const margin)) + :package-version '(ERC . "5.6")) ; FIXME sync on release + +(defcustom erc-stamp-right-margin-width nil + "Width in columns of the right margin. +When this option is nil, pretend its value is one column greater +than the `string-width' of the formatted `erc-timestamp-format'. +This option only matters when `erc-timestamp-use-align-to' is set +to `margin'." + :package-version '(ERC . "5.6") ; FIXME sync on release + :type '(choice (const nil) integer)) + +(defun erc-stamp--display-margin-force (orig &rest r) + (let ((erc-timestamp-use-align-to 'margin)) + (apply orig r))) + +(defun erc-stamp--adjust-right-margin (cols) + "Adjust right margin by COLS. +When COLS is zero, reset width to `erc-stamp-right-margin-width' +or one col more than the `string-width' of +`erc-timestamp-format'." + (let ((width + (if (zerop cols) + (or erc-stamp-right-margin-width + (1+ (string-width (or erc-timestamp-last-inserted-right + (erc-format-timestamp + (current-time) + erc-timestamp-format))))) + (+ right-margin-width cols)))) + (setq right-margin-width width + right-fringe-width 0) + (set-window-margins nil left-margin-width width) + (set-window-fringes nil left-fringe-width 0))) + +;;;###autoload +(defun erc-stamp-prefix-log-filter (text) + "Prefix every message in the buffer with a stamp. +Remove trailing stamps as well. For now, hard code the format to +\"ZNC\"-log style, which is [HH:MM:SS]. Expect to be used as a +`erc-log-filter-function' when `erc-timestamp-use-align-to' is +non-nil." + (insert text) + (goto-char (point-min)) + (while + (progn + (when-let* (((< (point) (pos-eol))) + (end (1- (pos-eol))) + ((eq 'erc-timestamp (field-at-pos end))) + (beg (field-beginning end)) + ;; Skip a line that's just a timestamp. + ((> beg (point)))) + (delete-region beg (1+ end))) + (when-let (time (get-text-property (point) 'erc-timestamp)) + (insert (format-time-string "[%H:%M:%S] " time))) + (zerop (forward-line)))) + "") + +(declare-function erc--remove-text-properties "erc" (string)) + +;; If people want to use this directly, we can convert it into +;; a local module. +(define-minor-mode erc-stamp--display-margin-mode + "Internal minor mode for built-in modules integrating with `stamp'. +It binds `erc-timestamp-use-align-to' to `margin' around calls to +`erc-insert-timestamp-function' in the current buffer, and sets +the right window margin to `erc-stamp-right-margin-width'. It +also arranges to remove most text properties when a user kills +message text so that stamps will be visible when yanked." + :interactive nil + (if erc-stamp--display-margin-mode + (progn + (erc-stamp--adjust-right-margin 0) + (add-function :filter-return (local 'filter-buffer-substring-function) + #'erc--remove-text-properties) + (add-function :around (local 'erc-insert-timestamp-function) + #'erc-stamp--display-margin-force)) + (remove-function (local 'filter-buffer-substring-function) + #'erc--remove-text-properties) + (remove-function (local 'erc-insert-timestamp-function) + #'erc-stamp--display-margin-force) + (kill-local-variable 'right-margin-width) + (kill-local-variable 'right-fringe-width) + (set-window-margins nil left-margin-width nil) + (set-window-fringes nil left-fringe-width nil))) (defun erc-insert-timestamp-left (string) "Insert timestamps at the beginning of the line." @@ -279,6 +375,7 @@ erc-insert-aligned If `erc-timestamp-use-align-to' is t, use the :align-to display property to get to the POSth column." + (declare (obsolete "inlined and removed from client code path" "30.1")) (if (not erc-timestamp-use-align-to) (indent-to pos) (insert " ") @@ -289,6 +386,8 @@ erc-insert-aligned ;; Silence byte-compiler (defvar erc-fill-column) +(defvar erc-stamp--inherited-props '(line-prefix wrap-prefix)) + (defun erc-insert-timestamp-right (string) "Insert timestamp on the right side of the screen. STRING is the timestamp to insert. This function is a possible @@ -340,12 +439,29 @@ erc-insert-timestamp-right ;; some margin of error if what is displayed on the line differs ;; from the number of characters on the line. (setq col (+ col (ceiling (/ (- col (- (point) (line-beginning-position))) 1.6)))) - (if (< col pos) - (erc-insert-aligned string pos) - (newline) - (indent-to pos) - (setq from (point)) - (insert string)) + ;; For compatibility reasons, the `erc-timestamp' field includes + ;; intervening white space unless a hard break is warranted. + (pcase erc-timestamp-use-align-to + ((and 't (guard (< col pos))) + (insert " ") + (put-text-property from (point) 'display `(space :align-to ,pos))) + ((pred integerp) ; (cl-type (integer 0 *)) + (insert " ") + (when (eq ?\s (aref string 0)) + (setq string (substring string 1))) + (let ((s (+ erc-timestamp-use-align-to (string-width string)))) + (put-text-property from (point) 'display + `(space :align-to (- right ,s))))) + ('margin + (put-text-property 0 (length string) + 'display `((margin right-margin) ,string) + string)) + ((guard (>= col pos)) (newline) (indent-to pos) (setq from (point))) + (_ (indent-to pos))) + (insert string) + (dolist (p erc-stamp--inherited-props) + (when-let ((v (get-text-property (1- from) p))) + (put-text-property from (point) p v))) (erc-put-text-property from (point) 'field 'erc-timestamp) (erc-put-text-property from (point) 'rear-nonsticky t) (when erc-timestamp-intangible diff --git a/test/lisp/erc/erc-stamp-tests.el b/test/lisp/erc/erc-stamp-tests.el index 935b9e650b3..01e71e348e0 100644 --- a/test/lisp/erc/erc-stamp-tests.el +++ b/test/lisp/erc/erc-stamp-tests.el @@ -68,7 +68,7 @@ erc-timestamp-use-align-to--nil (erc-display-message nil 'notice (current-buffer) "begin")) (goto-char (point-min)) (should (search-forward-regexp - (rx "begin" (+ "\t") (* " ") " [") nil t)) + (rx "begin" (+ "\t") (* " ") "[") nil t)) ;; Field includes intervening spaces (should (eql ?n (char-before (field-beginning (point))))) ;; Timestamp extends to the end of the line @@ -85,9 +85,9 @@ erc-timestamp-use-align-to--nil (erc-timestamp-right-column 20)) (erc-display-message nil 'notice (current-buffer) "twenty characters")) - (should (search-forward-regexp (rx bol (+ "\t") (* " ") " [") nil t)) + (should (search-forward-regexp (rx bol (+ "\t") (* " ") "[") nil t)) ;; Field excludes leading whitespace (arguably undesirable). - (should (eql ?\s (char-after (field-beginning (point))))) + (should (eql ?\[ (char-after (field-beginning (point))))) ;; Timestamp extends to the end of the line. (should (eql ?\n (char-after (field-end (point))))))))) @@ -101,7 +101,7 @@ erc-timestamp-use-align-to--t (erc-display-message nil nil (current-buffer) msg))) (goto-char (point-min)) ;; Exactly two spaces, one from format, one added by erc-stamp. - (should (search-forward "msg one [" nil t)) + (should (search-forward "msg one [" nil t)) ;; Field covers space between. (should (eql ?e (char-before (field-beginning (point))))) (should (eql ?\n (char-after (field-end (point)))))) @@ -112,9 +112,67 @@ erc-timestamp-use-align-to--t (let ((msg (erc-format-privmessage "bob" "tttt wwww oooo" nil t))) (erc-display-message nil nil (current-buffer) msg))) ;; Indented to pos (this is arguably a bug). - (should (search-forward-regexp (rx bol (+ "\t") (* " ") " [") nil t)) + (should (search-forward-regexp (rx bol (+ "\t") (* " ") "[") nil t)) ;; Field starts *after* leading space (arguably bad). - (should (eql ?\[ (char-after (1+ (field-beginning (point)))))) + (should (eql ?\[ (char-after (field-beginning (point))))) + (should (eql ?\n (char-after (field-end (point))))))))) + +(ert-deftest erc-timestamp-use-align-to--integer () + (erc-stamp-tests--insert-right + (lambda () + + (ert-info ("integer, normal") + (let ((erc-timestamp-use-align-to 1)) + (let ((msg (erc-format-privmessage "bob" "msg one" nil t))) + (erc-display-message nil nil (current-buffer) msg))) + (goto-char (point-min)) + ;; Space not added because included in format string. + (should (search-forward "msg one [" nil t)) + ;; Field covers space between. + (should (eql ?e (char-before (field-beginning (point))))) + (should (eql ?\n (char-after (field-end (point)))))) + + (ert-info ("integer, overlong (hard wrap)") + (let ((erc-timestamp-use-align-to 1) + (erc-timestamp-right-column 20)) + (let ((msg (erc-format-privmessage "bob" "tttt wwww oooo" nil t))) + (erc-display-message nil nil (current-buffer) msg))) + ;; No hard wrap + (should (search-forward "oooo [" nil t)) + ;; Field starts at leading space. + (should (eql ?\s (char-after (field-beginning (point))))) + (should (eql ?\n (char-after (field-end (point))))))))) + +(ert-deftest erc-timestamp-use-align-to--margin () + (erc-stamp-tests--insert-right + (lambda () + (erc-stamp--display-margin-mode +1) + + (ert-info ("margin, normal") + (let ((erc-timestamp-use-align-to 'margin)) + (let ((msg (erc-format-privmessage "bob" "msg one" nil t))) + (put-text-property 0 (length msg) 'wrap-prefix 10 msg) + (erc-display-message nil nil (current-buffer) msg))) + (goto-char (point-min)) + ;; Space not added (treated as opaque string). + (should (search-forward "msg one[" nil t)) + ;; Field covers stamp alone + (should (eql ?e (char-before (field-beginning (point))))) + ;; Vanity props extended + (should (get-text-property (field-beginning (point)) 'wrap-prefix)) + (should (get-text-property (1+ (field-beginning (point))) 'wrap-prefix)) + (should (get-text-property (1- (field-end (point))) 'wrap-prefix)) + (should (eql ?\n (char-after (field-end (point)))))) + + (ert-info ("margin, overlong (hard wrap)") + (let ((erc-timestamp-use-align-to 'margin) + (erc-timestamp-right-column 20)) + (let ((msg (erc-format-privmessage "bob" "tttt wwww oooo" nil t))) + (erc-display-message nil nil (current-buffer) msg))) + ;; No hard wrap + (should (search-forward "oooo[" nil t)) + ;; Field starts at format string (right bracket) + (should (eql ?\[ (char-after (field-beginning (point))))) (should (eql ?\n (char-after (field-end (point))))))))) ;; This concerns a proposed partial reversal of the changes resulting commit 379d35695b1985b71ff768c1e40d90f3b1da7fe6 Author: F. Jason Park Date: Wed Nov 24 05:35:35 2021 -0800 Make some erc-stamp functions more limber * lisp/erc/erc-stamp.el (erc-timestamp-format-right): Deprecate option and change meaning of its nil value to fall through to `erc-timestamp-format'. Do this to allow modules to predict what the right-hand stamp's final width will be. This also saves `erc-insert-timestamp-left-and-right' from calling `erc-format-timestamp' again for every inserted message. (erc-stamp-mode, erc-stamp-enable, erc-stamp-disable): Add `erc-stamp--recover-on-reconnect' to `erc-mode-hook'. (erc-stamp--recover-on-reconnect): Add function to reuse last values of `erc-timestamp-last-inserted' and friends to avoid reprinting stamps when reconnecting. (erc-stamp--current-time): Add new generic function and method to return current time. Default to calling `erc-current-time'. Also add new internal variable of the same name to hold time value used to construct formatted stamps passed to `erc-insert-timestamp-function'. (erc-add-timestamp): Bind `erc-stamp--current-time' when calling `erc-insert-timestamp-function'. (erc-stamp--insert-date-function): New variable for modules to tweak date-insertion. (erc-insert-timestamp-left-and-right): Use STRING parameter and favor it over the now deprecated `erc-timestamp-format-right' to avoid formatting twice. Also extract current time from the variable `erc-stamp--current-time' for similar reasons. And defer to `erc-stamp--insert-date-function' to insert left stamp. (Bug#60936.) (erc-stamp--tz): New internal variable. (erc-format-timestamp): Pass `erc-stamp--tz' as time-zone to `format-time-string'. diff --git a/lisp/erc/erc-stamp.el b/lisp/erc/erc-stamp.el index ce6e558aa4f..18371320300 100644 --- a/lisp/erc/erc-stamp.el +++ b/lisp/erc/erc-stamp.el @@ -55,6 +55,9 @@ erc-timestamp-format :type '(choice (const nil) (string))) +;; FIXME remove surrounding whitespace from default value and have +;; `erc-insert-timestamp-left-and-right' add it before insertion. + (defcustom erc-timestamp-format-left "\n[%a %b %e %Y]\n" "If set to a string, messages will be timestamped. This string is processed using `format-time-string'. @@ -68,7 +71,7 @@ erc-timestamp-format-left :type '(choice (const nil) (string))) -(defcustom erc-timestamp-format-right " [%H:%M]" +(defcustom erc-timestamp-format-right nil "If set to a string, messages will be timestamped. This string is processed using `format-time-string'. Good examples are \"%T\" and \"%H:%M\". @@ -77,9 +80,14 @@ erc-timestamp-format-right screen when `erc-insert-timestamp-function' is set to `erc-insert-timestamp-left-and-right'. -If nil, timestamping is turned off." +Unlike `erc-timestamp-format' and `erc-timestamp-format-left', if +the value of this option is nil, it falls back to using the value +of `erc-timestamp-format'." + :package-version '(ERC . "5.6") ; FIXME sync on release :type '(choice (const nil) (string))) +(make-obsolete-variable 'erc-timestamp-format-right + 'erc-timestamp-format "30.1") (defcustom erc-insert-timestamp-function 'erc-insert-timestamp-left-and-right "Function to use to insert timestamps. @@ -156,10 +164,34 @@ stamp "This mode timestamps messages in the channel buffers." ((add-hook 'erc-mode-hook #'erc-munge-invisibility-spec) (add-hook 'erc-insert-modify-hook #'erc-add-timestamp t) - (add-hook 'erc-send-modify-hook #'erc-add-timestamp t)) + (add-hook 'erc-send-modify-hook #'erc-add-timestamp t) + (add-hook 'erc-mode-hook #'erc-stamp--recover-on-reconnect)) ((remove-hook 'erc-mode-hook #'erc-munge-invisibility-spec) (remove-hook 'erc-insert-modify-hook #'erc-add-timestamp) - (remove-hook 'erc-send-modify-hook #'erc-add-timestamp))) + (remove-hook 'erc-send-modify-hook #'erc-add-timestamp) + (remove-hook 'erc-mode-hook #'erc-stamp--recover-on-reconnect))) + +(defun erc-stamp--recover-on-reconnect () + (when-let ((priors (or erc--server-reconnecting erc--target-priors))) + (dolist (var '(erc-timestamp-last-inserted + erc-timestamp-last-inserted-left + erc-timestamp-last-inserted-right)) + (when-let (existing (alist-get var priors)) + (set var existing))))) + +(defvar erc-stamp--current-time nil + "The current time when calling `erc-insert-timestamp-function'. +Specifically, this is the same lisp time object used to create +the stamp passed to `erc-insert-timestamp-function'.") + +(cl-defgeneric erc-stamp--current-time () + "Return a lisp time object to associate with an IRC message. +This becomes the message's `erc-timestamp' text property, which +may not be unique, `equal'-wise." + (erc-current-time)) + +(cl-defmethod erc-stamp--current-time :around () + (or erc-stamp--current-time (cl-call-next-method))) (defun erc-add-timestamp () "Add timestamp and text-properties to message. @@ -167,11 +199,11 @@ erc-add-timestamp This function is meant to be called from `erc-insert-modify-hook' or `erc-send-modify-hook'." (unless (get-text-property (point-min) 'invisible) - (let ((ct (current-time))) - (if (fboundp erc-insert-timestamp-function) - (funcall erc-insert-timestamp-function - (erc-format-timestamp ct erc-timestamp-format)) - (error "Timestamp function unbound")) + (let* ((ct (erc-stamp--current-time)) + (erc-stamp--current-time ct)) + (funcall erc-insert-timestamp-function + (erc-format-timestamp ct erc-timestamp-format)) + ;; FIXME this will error when advice has been applied. (when (and (fboundp erc-insert-away-timestamp-function) erc-away-timestamp-format (erc-away-time) @@ -319,19 +351,29 @@ erc-insert-timestamp-right (when erc-timestamp-intangible (erc-put-text-property from (1+ (point)) 'cursor-intangible t))))) -(defun erc-insert-timestamp-left-and-right (_string) - "This is another function that can be used with `erc-insert-timestamp-function'. -If the date is changed, it will print a blank line, the date, and -another blank line. If the time is changed, it will then print -it off to the right." - (let* ((ct (current-time)) - (ts-left (erc-format-timestamp ct erc-timestamp-format-left)) - (ts-right (erc-format-timestamp ct erc-timestamp-format-right))) +(defvar erc-stamp--insert-date-function #'insert + "Function to insert left \"left-right date\" stamp. +A local module might use this to modify text properties, +`insert-before-markers' or renarrow the region after insertion.") + +(defun erc-insert-timestamp-left-and-right (string) + "Insert a stamp on either side when it changes. +When the deprecated option `erc-timestamp-format-right' is nil, +use STRING, which originates from `erc-timestamp-format', for the +right-hand stamp. Use `erc-timestamp-format-left' for the +left-hand stamp and expect it to change less frequently." + (let* ((ct (or erc-stamp--current-time (erc-stamp--current-time))) + (ts-left (erc-format-timestamp ct erc-timestamp-format-left)) + (ts-right (with-suppressed-warnings + ((obsolete erc-timestamp-format-right)) + (if erc-timestamp-format-right + (erc-format-timestamp ct erc-timestamp-format-right) + string)))) ;; insert left timestamp (unless (string-equal ts-left erc-timestamp-last-inserted-left) (goto-char (point-min)) (erc-put-text-property 0 (length ts-left) 'field 'erc-timestamp ts-left) - (insert ts-left) + (funcall erc-stamp--insert-date-function ts-left) (setq erc-timestamp-last-inserted-left ts-left)) ;; insert right timestamp (let ((erc-timestamp-only-if-changed-flag t) @@ -340,12 +382,13 @@ erc-insert-timestamp-left-and-right (setq erc-timestamp-last-inserted-right ts-right)))) ;; for testing: (setq erc-timestamp-only-if-changed-flag nil) +(defvar erc-stamp--tz nil) (defun erc-format-timestamp (time format) "Return TIME formatted as string according to FORMAT. Return the empty string if FORMAT is nil." (if format - (let ((ts (format-time-string format time))) + (let ((ts (format-time-string format time erc-stamp--tz))) (erc-put-text-property 0 (length ts) 'font-lock-face 'erc-timestamp-face ts) (erc-put-text-property 0 (length ts) 'invisible 'timestamp ts) commit ad3dc74e074719a58226e23a45c4556cd54c0a48 Author: F. Jason Park Date: Wed Nov 24 03:10:20 2021 -0800 Expose insertion time as text prop in erc-stamp * lisp/erc/erc-stamp.el (erc-add-timestamp): Add new text property `erc-timestamp' to store lisp time object formerly ensconced in a closure. Instead of creating a new lambda for the cursor-sensor function of each message in a buffer, leave a gap between messages to trip the sensor function. The motivation behind this change is to allow third parties access to valuable timestamp data already stored by ERC anyway. Of secondary importance is discouraging the reliance on those lambdas as a means of detecting message bounds. The gap now serves a similar purpose. Basically, the final character in a message, a newline, will not have a timestamp or a sensor function. In the rare instance the stamps module isn't loaded, the new `erc-command' property can be used for this purpose instead. Also, instead of looking for the `invisible' text property at point, which is normally `point-max' and thus outside the accessible portion of the buffer, look at the beginning of the inserted message. This allows hook members running before this function to opt out of timestamps by marking a message as invisible. (erc-echo-timestamp): Make interactive and show timestamps even when the variable `erc-echo-timestamps' is nil. (erc--echo-ts-csf): Add new function to serve as value of cursor-sensor function text properties. * test/lisp/erc/erc-stamp-tests.el: New file. (Bug#60936.) diff --git a/lisp/erc/erc-stamp.el b/lisp/erc/erc-stamp.el index d1a1507f700..ce6e558aa4f 100644 --- a/lisp/erc/erc-stamp.el +++ b/lisp/erc/erc-stamp.el @@ -166,7 +166,7 @@ erc-add-timestamp This function is meant to be called from `erc-insert-modify-hook' or `erc-send-modify-hook'." - (unless (get-text-property (point) 'invisible) + (unless (get-text-property (point-min) 'invisible) (let ((ct (current-time))) (if (fboundp erc-insert-timestamp-function) (funcall erc-insert-timestamp-function @@ -178,12 +178,12 @@ erc-add-timestamp (not erc-timestamp-format)) (funcall erc-insert-away-timestamp-function (erc-format-timestamp ct erc-away-timestamp-format))) - (add-text-properties (point-min) (point-max) + (add-text-properties (point-min) (1- (point-max)) ;; It's important for the function to ;; be different on different entries (bug#22700). (list 'cursor-sensor-functions - (list (lambda (_window _before dir) - (erc-echo-timestamp dir ct)))))))) + ;; Regions are no longer contiguous ^ + '(erc--echo-ts-csf) 'erc-timestamp ct))))) (defvar-local erc-timestamp-last-window-width nil "The width of the last window that showed the current buffer. @@ -404,11 +404,16 @@ erc-toggle-timestamps (defun erc-echo-timestamp (dir stamp) "Print timestamp text-property of an IRC message." - (when (and erc-echo-timestamps (eq 'entered dir)) + ;; Could also pass an &optional `zone' arg to `format-time-string'. + (interactive (list 'entered (get-text-property (point) 'erc-timestamp))) + (when (eq 'entered dir) (when stamp (message "%s" (format-time-string erc-echo-timestamp-format stamp))))) +(defun erc--echo-ts-csf (_window _before dir) + (erc-echo-timestamp dir (get-text-property (point) 'erc-timestamp))) + (provide 'erc-stamp) ;;; erc-stamp.el ends here diff --git a/test/lisp/erc/erc-stamp-tests.el b/test/lisp/erc/erc-stamp-tests.el new file mode 100644 index 00000000000..935b9e650b3 --- /dev/null +++ b/test/lisp/erc/erc-stamp-tests.el @@ -0,0 +1,207 @@ +;;; erc-stamp-tests.el --- Tests for erc-stamp. -*- lexical-binding:t -*- + +;; Copyright (C) 2023 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-stamp) +(require 'erc-goodies) ; for `erc-make-read-only' + +;; These display-oriented tests are brittle because many factors +;; influence how text properties are applied. We should just +;; rework these into full scenarios. + +(defun erc-stamp-tests--insert-right (test) + (let ((val (list 0 0)) + (erc-insert-modify-hook '(erc-add-timestamp)) + (erc-insert-post-hook '(erc-make-read-only)) ; see comment above + (erc-timestamp-only-if-changed-flag nil) + ;; + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + + (advice-add 'erc-format-timestamp :filter-args + (lambda (args) (cons (cl-incf (cadr val) 60) (cdr args))) + '((name . ert-deftest--erc-timestamp-use-align-to))) + + (with-current-buffer (get-buffer-create "*erc-stamp-tests--insert-right*") + (erc-mode) + (erc-munge-invisibility-spec) + (setq erc-server-process (start-process "p" (current-buffer) + "sleep" "1") + erc-input-marker (make-marker) + erc-insert-marker (make-marker)) + (set-process-query-on-exit-flag erc-server-process nil) + (set-marker erc-insert-marker (point-max)) + (erc-display-prompt) + + (funcall test) + + (when noninteractive + (kill-buffer))) + + (advice-remove 'erc-format-timestamp + 'ert-deftest--erc-timestamp-use-align-to))) + +(ert-deftest erc-timestamp-use-align-to--nil () + (erc-stamp-tests--insert-right + (lambda () + + (ert-info ("nil, normal") + (let ((erc-timestamp-use-align-to nil)) + (erc-display-message nil 'notice (current-buffer) "begin")) + (goto-char (point-min)) + (should (search-forward-regexp + (rx "begin" (+ "\t") (* " ") " [") nil t)) + ;; Field includes intervening spaces + (should (eql ?n (char-before (field-beginning (point))))) + ;; Timestamp extends to the end of the line + (should (eql ?\n (char-after (field-end (point)))))) + + ;; The option `erc-timestamp-right-column' is normally nil by + ;; default, but it's a convenient stand in for a sufficiently + ;; small `erc-fill-column' (we can force a line break without + ;; involving that module). + (should-not erc-timestamp-right-column) + + (ert-info ("nil, overlong (hard wrap)") + (let ((erc-timestamp-use-align-to nil) + (erc-timestamp-right-column 20)) + (erc-display-message nil 'notice (current-buffer) + "twenty characters")) + (should (search-forward-regexp (rx bol (+ "\t") (* " ") " [") nil t)) + ;; Field excludes leading whitespace (arguably undesirable). + (should (eql ?\s (char-after (field-beginning (point))))) + ;; Timestamp extends to the end of the line. + (should (eql ?\n (char-after (field-end (point))))))))) + +(ert-deftest erc-timestamp-use-align-to--t () + (erc-stamp-tests--insert-right + (lambda () + + (ert-info ("t, normal") + (let ((erc-timestamp-use-align-to t)) + (let ((msg (erc-format-privmessage "bob" "msg one" nil t))) + (erc-display-message nil nil (current-buffer) msg))) + (goto-char (point-min)) + ;; Exactly two spaces, one from format, one added by erc-stamp. + (should (search-forward "msg one [" nil t)) + ;; Field covers space between. + (should (eql ?e (char-before (field-beginning (point))))) + (should (eql ?\n (char-after (field-end (point)))))) + + (ert-info ("t, overlong (hard wrap)") + (let ((erc-timestamp-use-align-to t) + (erc-timestamp-right-column 20)) + (let ((msg (erc-format-privmessage "bob" "tttt wwww oooo" nil t))) + (erc-display-message nil nil (current-buffer) msg))) + ;; Indented to pos (this is arguably a bug). + (should (search-forward-regexp (rx bol (+ "\t") (* " ") " [") nil t)) + ;; Field starts *after* leading space (arguably bad). + (should (eql ?\[ (char-after (1+ (field-beginning (point)))))) + (should (eql ?\n (char-after (field-end (point))))))))) + +;; This concerns a proposed partial reversal of the changes resulting +;; from: +;; +;; 24.1.50; Wrong behavior of move-end-of-line in ERC (Bug#11706) +;; +;; Perhaps core behavior has changed since this bug was reported, but +;; C-e stopping one char short of EOL no longer seems a problem. +;; However, invoking C-n (`next-line') exhibits a similar effect. +;; When point is in a stamp or near the beginning of a line, issuing a +;; C-n puts point one past the start of the message (i.e., two chars +;; beyond the timestamp's closing "]". Dropping the invisible +;; property when timestamps are hidden does indeed prevent this, but +;; it's also a lasting commitment. The docs mention that it's +;; pointless to pair the old `intangible' property with `invisible' +;; and suggest users look at `cursor-intangible-mode'. Turning off +;; the latter does indeed do the trick as does decrementing the end of +;; the `cursor-intangible' interval so that, in addition to C-n +;; working, a C-f from before the timestamp doesn't overshoot. This +;; appears to be the case whether `erc-hide-timestamps' is enabled or +;; not, but it may be inadvisable for some reason (a hack) and +;; therefore warrants further investigation. +;; +;; Note some striking omissions here: +;; +;; 1. a lack of `fill' module integration (we simulate it by +;; making lines short enough to not wrap) +;; 2. functions like `line-move' behave differently when +;; `noninteractive' +;; 3. no actual test assertions involving `cursor-sensor' movement +;; even though that's a huge ingredient + +(ert-deftest erc-timestamp-intangible--left () + (let ((erc-timestamp-only-if-changed-flag nil) + (erc-timestamp-intangible t) ; default changed to nil in 2014 + (erc-hide-timestamps t) + (erc-insert-timestamp-function 'erc-insert-timestamp-left) + (erc-server-process (start-process "true" (current-buffer) "true")) + (erc-insert-modify-hook '(erc-make-read-only erc-add-timestamp)) + msg + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + (should (not cursor-sensor-inhibit)) + (set-process-query-on-exit-flag erc-server-process nil) + (erc-mode) + (with-current-buffer (get-buffer-create "*erc-timestamp-intangible*") + (erc-mode) + (erc--initialize-markers (point) nil) + (erc-munge-invisibility-spec) + (erc-display-message nil 'notice (current-buffer) "Welcome") + ;; + ;; Pretend `fill' is active and that these lines are + ;; folded. Otherwise, there's an annoying issue on wrapped lines + ;; (when visual-line-mode is off and stamps are visible) where + ;; C-e sends you to the end of the previous line. + (setq msg "Lorem ipsum dolor sit amet") + (erc-display-message nil nil (current-buffer) + (erc-format-privmessage "alyssa" msg nil t)) + (erc-display-message nil 'notice (current-buffer) "Home") + (goto-char (point-min)) + + ;; EOL is actually EOL (Bug#11706) + + (ert-info ("Notice before stamp, C-e") ; first line/stamp + (should (search-forward "Welcome" nil t)) + (ert-simulate-command '(erc-bol)) + (should (looking-at (rx "["))) + (let ((end (pos-eol))) ; `line-end-position' fails because fields + (ert-simulate-command '(move-end-of-line 1)) + (should (= end (point))))) + + (ert-info ("Privmsg before stamp, C-e") + (should (search-forward "Lorem" nil t)) + (goto-char (pos-bol)) + (should (looking-at (rx "["))) + (let ((end (pos-eol))) + (ert-simulate-command '(move-end-of-line 1)) + (should (= end (point))))) + + (ert-info ("Privmsg first line, C-e") + (goto-char (pos-bol)) + (should (search-forward "ipsum" nil t)) + (let ((end (pos-eol))) + (ert-simulate-command '(move-end-of-line 1)) + (should (= end (point))))) + + (when noninteractive + (kill-buffer))))) + +;;; erc-stamp-tests.el ends here commit 8793874616f1020f7af5149643a75d551887ea5c Author: F. Jason Park Date: Thu Jun 16 01:20:49 2022 -0700 Adjust some old text properties in ERC buffers * lisp/erc/erc.el (erc-display-message): Replace `rear-sticky' text property, which has been around since 2002, with a more useful `erc-command' property. It records the current IRC command as a symbol or a number, in the case of numerics. (erc--own-property-names, erc--remove-text-properties) Add variable and internal helper function for filtering values returned by `filter-buffer-substring-function'. (erc-display-prompt): Make the `field' text property more meaningful to aid in searching, although this makes the `erc-prompt' property somewhat redundant. (erc-put-text-property, erc-list): Alias these to subr functions. (erc-restore-text-properties): Don't forget tags when restoring. (erc--get-eq-comparable-cmd): New function to extract commands for use as more easily searchable text-property values. (Bug#60936.) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index e8bd4ace1a6..5aa460241cd 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -2994,7 +2994,9 @@ erc-display-message (erc-display-line string buffer) (unless (erc-hide-current-message-p parsed) (erc-put-text-property 0 (length string) 'erc-parsed parsed string) - (erc-put-text-property 0 (length string) 'rear-sticky t string) + (put-text-property + 0 (length string) 'erc-command + (erc--get-eq-comparable-cmd (erc-response.command parsed)) string) (when (erc-response.tags parsed) (erc-put-text-property 0 (length string) 'tags (erc-response.tags parsed) string)) @@ -4394,6 +4396,30 @@ erc-ensure-channel-name channel (concat "#" channel))) +(defvar erc--own-property-names + '( tags erc-parsed display ; core + ;; `erc-display-prompt' + rear-nonsticky erc-prompt field front-sticky read-only + ;; stamp + cursor-intangible cursor-sensor-functions isearch-open-invisible + ;; match + invisible intangible + ;; button + erc-callback erc-data mouse-face keymap + ;; fill-wrap + line-prefix wrap-prefix) + "Props added by ERC that should not survive killing. +Among those left behind by default are `font-lock-face' and +`erc-secret'.") + +(defun erc--remove-text-properties (string) + "Remove text properties in STRING added by ERC. +Specifically, remove any that aren't members of +`erc--own-property-names'." + (remove-list-of-text-properties 0 (length string) + erc--own-property-names string) + string) + (defun erc-grab-region (start end) "Copy the region between START and END in a recreatable format. @@ -4445,7 +4471,7 @@ erc-display-prompt (setq prompt (propertize prompt 'rear-nonsticky t 'erc-prompt t - 'field t + 'field 'erc-prompt 'front-sticky t 'read-only t)) (erc-put-text-property 0 (1- (length prompt)) @@ -5847,7 +5873,7 @@ erc-highlight-error (erc-put-text-property 0 (length s) 'font-lock-face 'erc-error-face s) s) -(defun erc-put-text-property (start end property value &optional object) +(defalias 'erc-put-text-property 'put-text-property "Set text-property for an object (usually a string). START and END define the characters covered. PROPERTY is the text-property set, usually the symbol `face'. @@ -5857,14 +5883,9 @@ erc-put-text-property OBJECT is modified without being copied first. You can redefine or `defadvice' this function in order to add -EmacsSpeak support." - (put-text-property start end property value object)) +EmacsSpeak support.") -(defun erc-list (thing) - "Return THING if THING is a list, or a list with THING as its element." - (if (listp thing) - thing - (list thing))) +(defalias 'erc-list 'ensure-list) (defun erc-parse-user (string) "Parse STRING as a user specification (nick!login@host). @@ -7451,10 +7472,11 @@ erc-find-parsed-property (defun erc-restore-text-properties () "Restore the property `erc-parsed' for the region." - (let ((parsed-posn (erc-find-parsed-property))) - (put-text-property - (point-min) (point-max) - 'erc-parsed (when parsed-posn (erc-get-parsed-vector parsed-posn))))) + (when-let* ((parsed-posn (erc-find-parsed-property)) + (found (erc-get-parsed-vector parsed-posn))) + (put-text-property (point-min) (point-max) 'erc-parsed found) + (when-let ((tags (get-text-property parsed-posn 'tags))) + (put-text-property (point-min) (point-max) 'tags tags)))) (defun erc-get-parsed-vector (point) "Return the whole parsed vector on POINT." @@ -7474,6 +7496,13 @@ erc-get-parsed-vector-type (and vect (erc-response.command vect))) +(defun erc--get-eq-comparable-cmd (command) + "Return a symbol or a fixnum representing a message's COMMAND. +See also `erc-message-type'." + ;; IRC numerics are three-digit numbers, possibly with leading 0s. + ;; To invert: (if (numberp o) (format "%03d" o) (symbol-name o)) + (if-let* ((n (string-to-number command)) ((zerop n))) (intern command) n)) + ;; Teach url.el how to open irc:// URLs with ERC. ;; To activate, customize `url-irc-function' to `url-irc-erc'. commit d5435a0d822e95bfb18f3cdf4fac83611ec17972 Author: F. Jason Park Date: Mon Jan 23 20:48:24 2023 -0800 Refactor marker initialization in erc-open * lisp/erc/erc.el (erc--initialize-markers): New helper to ensure prompt and its associated markers are set up correctly. (erc-open): When determining whether a session is a logical continuation, leverage the work already performed by the `erc-networks' library to that effect. Its verdicts are based on network context and thus reliable even when a user dials anew from an entry-point, which is not a simple reconnection because the user expects a clean slate for everything except an existing buffer's messages, meaning `erc--server-reconnecting' will be nil and local-module state variables need resetting. Also remove the check for `erc-reuse-buffers' and instead trust that `erc-get-buffer-create' always does the right thing. Replace all code involving marker and prompt setup by deferring to a new helper, `erc--initialize markers'. * test/lisp/erc/erc-scenarios-base-local-module-modes.el: New file. * test/lisp/erc/erc-scenarios-base-local-modules.el (erc-scenarios-base-local-modules--mode-persistence): Move test to separate file to help with parallel "-j" runs. * test/lisp/erc/erc-tests.el (erc-tests--send-prep): Replace redundant prompt-setup code. (erc--initialize-markers): New test. (Bug#60936.) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 6e14f4780e4..e8bd4ace1a6 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -2051,6 +2051,35 @@ erc--merge-local-modes (cons (nreverse (car out)) (nreverse (cdr out)))) (list new-modes))) +;; This function doubles as a convenient helper for use in unit tests. +;; Prior to 5.6, its contents lived in `erc-open'. + +(defun erc--initialize-markers (old-point continued-session) + "Ensure prompt and its bounding markers have been initialized." + ;; FIXME erase assertions after code review and additional testing. + (setq erc-insert-marker (make-marker) + erc-input-marker (make-marker)) + (if continued-session + (progn + ;; Trust existing markers. + (set-marker erc-insert-marker + (alist-get 'erc-insert-marker continued-session)) + (set-marker erc-input-marker + (alist-get 'erc-input-marker continued-session)) + (goto-char erc-insert-marker) + (cl-assert (= (field-end) erc-input-marker)) + (goto-char old-point) + (erc--unhide-prompt)) + (cl-assert (not (get-text-property (point) 'erc-prompt))) + ;; In the original version from `erc-open', the snippet that + ;; handled these newline insertions appeared twice close in + ;; proximity, which was probably unintended. Nevertheless, we + ;; preserve the double newlines here for historical reasons. + (insert "\n\n") + (set-marker erc-insert-marker (point)) + (erc-display-prompt) + (cl-assert (= (point) (point-max))))) + (defun erc-open (&optional server port nick full-name connect passwd tgt-list channel process client-certificate user id) @@ -2084,10 +2113,13 @@ erc-open (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)))) + (continued-session (or erc--server-reconnecting + erc--target-priors + (and-let* (((not target)) + (m (buffer-local-value + 'erc-input-marker buffer)) + ((marker-position m))) + (buffer-local-variables buffer))))) (when connect (run-hook-with-args 'erc-before-connect server port nick)) (set-buffer buffer) (setq old-point (point)) @@ -2105,21 +2137,6 @@ erc-open (buffer-local-value 'erc-server-announced-name old-buffer))) ;; connection parameters (setq erc-server-process process) - (setq erc-insert-marker (make-marker)) - (setq erc-input-marker (make-marker)) - ;; go to the end of the buffer and open a new line - ;; (the buffer may have existed) - (goto-char (point-max)) - (forward-line 0) - (when (or continued-session (get-text-property (point) 'erc-prompt)) - (setq continued-session t) - (set-marker erc-input-marker - (or (next-single-property-change (point) 'erc-prompt) - (point-max)))) - (unless continued-session - (goto-char (point-max)) - (insert "\n")) - (set-marker erc-insert-marker (point)) ;; stack of default recipients (setq erc-default-recipients tgt-list) (when target @@ -2166,20 +2183,7 @@ erc-open (get-buffer-create (concat "*ERC-DEBUG: " server "*")))) (erc-determine-parameters server port nick full-name user passwd) - - ;; FIXME consolidate this prompt-setup logic with the pass above. - - ;; set up prompt - (unless continued-session - (goto-char (point-max)) - (insert "\n")) - (if continued-session - (progn (goto-char old-point) - (erc--unhide-prompt)) - (set-marker erc-insert-marker (point)) - (erc-display-prompt) - (goto-char (point-max))) - + (erc--initialize-markers old-point continued-session) (save-excursion (run-mode-hooks) (dolist (mod (car delayed-modules)) (funcall mod +1)) (dolist (var (cdr delayed-modules)) (set var nil))) diff --git a/test/lisp/erc/erc-scenarios-base-local-module-modes.el b/test/lisp/erc/erc-scenarios-base-local-module-modes.el new file mode 100644 index 00000000000..7b91e28dc83 --- /dev/null +++ b/test/lisp/erc/erc-scenarios-base-local-module-modes.el @@ -0,0 +1,211 @@ +;;; erc-scenarios-base-local-module-modes.el --- More local-mod ERC tests -*- lexical-binding: t -*- + +;; Copyright (C) 2023 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: + +;; A local module doubles as a minor mode whose mode variable and +;; associated local data can withstand service disruptions. +;; Unfortunately, the current implementation is too unwieldy to be +;; made public because it doesn't perform any of the boiler plate +;; needed to save and restore buffer-local and "network-local" copies +;; of user options. Ultimately, a user-friendly framework must fill +;; this void if third-party local modules are ever to become +;; practical. +;; +;; The following tests all use `sasl' because, as of ERC 5.5, it's the +;; only local module. + +;;; Code: + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +(require 'erc-sasl) + +;; 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-module-modes--reconnect () + :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 ""))))) + +;; In contrast to the mode-persistence test above, this one +;; demonstrates that a user reinvoking an entry point declares their +;; intention to reset local-module state for the server buffer. +;; Whether a local-module's state variable is also reset in target +;; buffers up to the module. That is, by default, they're left alone. + +(ert-deftest erc-scenarios-base-local-module-modes--entrypoint () + :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 'first)) + (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") + + (ert-info ("Toggle local-module off in target buffer") + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) + (funcall expect 20 "She is Lavinia, therefore must") + (erc-sasl-mode -1))) + + (erc-cmd-QUIT "") + (funcall expect 10 "finished") + + (ert-info ("Toggle mode off") + (erc-sasl-mode -1) + (should (local-variable-p 'erc-sasl-mode))))) + + (ert-info ("Reconnecting via entry point discards `erc-sasl-mode' value.") + ;; If you were to /RECONNECT here, no PASS changeme would be + ;; sent instead of CAP SASL, resulting in a failure. + (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") + + (erc-d-t-wait-for 10 (equal (buffer-name) "foonet")) + (funcall expect 10 "User modes for tester") + (should erc-sasl-mode)) ; obviously + + ;; No other foonet buffer exists, e.g., foonet<2> + (should-not (cdr (erc-scenarios-common-buflist "foonet"))) + + (ert-info ("Target buffer retains local-module state") + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) + (funcall expect 20 "She is Lavinia, therefore must") + (should-not erc-sasl-mode) + (should (local-variable-p 'erc-sasl-mode)) + (erc-cmd-QUIT "")))))) + +;;; erc-scenarios-base-local-module-modes.el ends here diff --git a/test/lisp/erc/erc-scenarios-base-local-modules.el b/test/lisp/erc/erc-scenarios-base-local-modules.el index 1318207a3bf..d6dbd87c8cc 100644 --- a/test/lisp/erc/erc-scenarios-base-local-modules.el +++ b/test/lisp/erc/erc-scenarios-base-local-modules.el @@ -82,105 +82,6 @@ erc-scenarios-base-local-modules--reconnect-let (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. diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index b2f24aa718e..6e66de53edd 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -117,11 +117,7 @@ erc-tests--send-prep ;; Caller should probably shadow `erc-insert-modify-hook' or ;; populate user tables for erc-button. (erc-mode) - (insert "\n\n") - (setq erc-input-marker (make-marker) - erc-insert-marker (make-marker)) - (set-marker erc-insert-marker (point-max)) - (erc-display-prompt) + (erc--initialize-markers (point) nil) (should (= (point) erc-input-marker))) (defun erc-tests--set-fake-server-process (&rest args) @@ -257,6 +253,79 @@ erc-hide-prompt (kill-buffer "bob") (kill-buffer "ServNet")))) +(ert-deftest erc--initialize-markers () + (let ((proc (start-process "true" (current-buffer) "true")) + erc-modules + erc-connect-pre-hook + erc-insert-modify-hook + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + (set-process-query-on-exit-flag proc nil) + (erc-mode) + (setq erc-server-process proc + erc-networks--id (erc-networks--id-create 'foonet)) + (erc-open "localhost" 6667 "tester" "Tester" nil + "fake" nil "#chan" proc nil "user" nil) + (with-current-buffer (should (get-buffer "#chan")) + (should (= ?\n (char-after 1))) + (should (= ?E (char-after erc-insert-marker))) + (should (= 3 (marker-position erc-insert-marker))) + (should (= 8 (marker-position erc-input-marker))) + (should (= 8 (point-max))) + (should (= 8 (point))) + ;; These prompt properties are a continual source of confusion. + ;; Including the literal defaults here can hopefully serve as a + ;; quick reference for anyone operating in that area. + (should (equal (buffer-string) + #("\n\nERC> " + 2 6 ( font-lock-face erc-prompt-face + rear-nonsticky t + erc-prompt t + field erc-prompt + front-sticky t + read-only t) + 6 7 ( rear-nonsticky t + erc-prompt t + field erc-prompt + front-sticky t + read-only t)))) + + ;; Simulate some activity by inserting some text before and + ;; after the prompt (multiline). + (erc-display-error-notice nil "Welcome") + (goto-char (point-max)) + (insert "Hello\nWorld") + (goto-char 3) + (should (looking-at-p (regexp-quote "*** Welcome")))) + + (ert-info ("Reconnect") + (erc-open "localhost" 6667 "tester" "Tester" nil + "fake" nil "#chan" proc nil "user" nil) + (should-not (get-buffer "#chan<2>"))) + + (ert-info ("Existing prompt respected") + (with-current-buffer (should (get-buffer "#chan")) + (should (= ?\n (char-after 1))) + (should (= ?E (char-after erc-insert-marker))) + (should (= 15 (marker-position erc-insert-marker))) + (should (= 20 (marker-position erc-input-marker))) + (should (= 3 (point))) ; point restored + (should (equal (buffer-string) + #("\n\n*** Welcome\nERC> Hello\nWorld" + 2 13 (font-lock-face erc-error-face) + 14 18 ( font-lock-face erc-prompt-face + rear-nonsticky t + erc-prompt t + field erc-prompt + front-sticky t + read-only t) + 18 19 ( rear-nonsticky t + erc-prompt t + field erc-prompt + front-sticky t + read-only t)))) + (when noninteractive + (kill-buffer)))))) + (ert-deftest erc--switch-to-buffer () (defvar erc-modified-channels-alist) ; lisp/erc/erc-track.el commit 05f6fdb9e7893329baff675bd31fb36ad64c756d Author: F. Jason Park Date: Sun Feb 19 21:33:36 2023 -0800 Preserve ERC prompt and its bounding markers * lisp/erc/erc.el (erc--assert-input-bounds): Add possibly temporary helper function to sync `process-mark' to `erc-insert-marker' in server buffer. (erc-display-line-1): Expect `erc-insert-marker' to always be initialized. Assert some essential invariants regarding insert markers. (erc-send-current-line): Delete typed input but not the prompt. (erc-display-msg): Rework slightly to respect existing markers. * test/lisp/erc/erc-dcc-tests.el (erc-dcc-tests--dcc-handle-ctcp-send): Set insert marker. * test/lisp/erc/erc-networks-tests.el (erc-networks--rename-server-buffer--existing-live): Initialize markers to appease `erc--assert-input-bounds'. * test/lisp/erc/erc-tests.el (erc-ring-previous-command): Fix sloppy mock. (Bug#60936.) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 85f0416f44b..6e14f4780e4 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -2632,6 +2632,16 @@ erc-remove-parsed-property :type 'boolean :group 'erc) +(define-inline erc--assert-input-bounds () + (inline-quote + (progn (when (and (processp erc-server-process) + (eq (current-buffer) (process-buffer erc-server-process))) + ;; It's believed that these only need syncing immediately + ;; following the first two insertions in a server buffer. + (set-marker (process-mark erc-server-process) erc-insert-marker)) + (cl-assert (< erc-insert-marker erc-input-marker)) + (cl-assert (= (field-end erc-insert-marker) erc-input-marker))))) + (defun erc-display-line-1 (string buffer) "Display STRING in `erc-mode' BUFFER. Auxiliary function used in `erc-display-line'. The line gets filtered to @@ -2641,8 +2651,7 @@ erc-display-line-1 If STRING is nil, the function does nothing." (when string (with-current-buffer (or buffer (process-buffer erc-server-process)) - (let ((insert-position (or (marker-position erc-insert-marker) - (point-max)))) + (let ((insert-position (marker-position erc-insert-marker))) (let ((string string) ;; FIXME! Can this be removed? (buffer-undo-list t) (inhibit-read-only t)) @@ -2667,6 +2676,7 @@ erc-display-line-1 (widen) (goto-char insert-position) (insert-before-markers string) + (erc--assert-input-bounds) ;; run insertion hook, with point at restored location (save-restriction (narrow-to-region insert-position (point)) @@ -2674,7 +2684,8 @@ erc-display-line-1 (run-hooks 'erc-insert-post-hook) (when erc-remove-parsed-property (remove-text-properties (point-min) (point-max) - '(erc-parsed nil)))))))) + '(erc-parsed nil)))) + (erc--assert-input-bounds))))) (run-hooks 'erc-insert-done-hook) (erc-update-undo-list (- (or (marker-position erc-insert-marker) (point-max)) @@ -6006,8 +6017,7 @@ erc-send-current-line (progn ; unprogn this during next major surgery (erc-set-active-buffer (current-buffer)) ;; Kill the input and the prompt - (delete-region (erc-beg-of-input-line) - (erc-end-of-input-line)) + (delete-region erc-input-marker (erc-end-of-input-line)) (unwind-protect (erc-send-input str 'skip-ws-chk) ;; Fix the buffer if the command didn't kill it @@ -6015,12 +6025,7 @@ erc-send-current-line (with-current-buffer old-buf (save-restriction (widen) - (goto-char (point-max)) - (when (processp erc-server-process) - (set-marker (process-mark erc-server-process) (point))) - (set-marker erc-insert-marker (point)) (let ((buffer-modified (buffer-modified-p))) - (erc-display-prompt) (set-buffer-modified-p buffer-modified)))))) ;; Only when last hook has been run... @@ -6106,21 +6111,21 @@ erc-send-input (defun erc-display-msg (line) "Display LINE as a message of the user to the current target at point." (when erc-insert-this - (let ((insert-position (point))) - (insert (erc-format-my-nick)) - (let ((beg (point))) - (insert line) - (erc-put-text-property beg (point) - 'font-lock-face 'erc-input-face)) - (insert "\n") - (when (processp erc-server-process) - (set-marker (process-mark erc-server-process) (point))) - (set-marker erc-insert-marker (point)) - (save-excursion + (save-excursion + (erc--assert-input-bounds) + (let ((insert-position (marker-position erc-insert-marker)) + beg) + (goto-char insert-position) + (insert-before-markers (erc-format-my-nick)) + (setq beg (point)) + (insert-before-markers line) + (erc-put-text-property beg (point) 'font-lock-face 'erc-input-face) + (insert-before-markers "\n") (save-restriction (narrow-to-region insert-position (point)) (run-hooks 'erc-send-modify-hook) - (run-hooks 'erc-send-post-hook)))))) + (run-hooks 'erc-send-post-hook)) + (erc--assert-input-bounds))))) (defun erc-command-symbol (command) "Return the ERC command symbol for COMMAND if it exists and is bound." diff --git a/test/lisp/erc/erc-dcc-tests.el b/test/lisp/erc/erc-dcc-tests.el index fed86eff2c5..7fb5f82e784 100644 --- a/test/lisp/erc/erc-dcc-tests.el +++ b/test/lisp/erc/erc-dcc-tests.el @@ -60,6 +60,8 @@ erc-dcc-tests--dcc-handle-ctcp-send erc-input-marker (make-marker) erc-insert-marker (make-marker) erc-server-current-nick "dummy") + (erc-display-prompt) + (set-marker erc-insert-marker (pos-bol)) (set-process-query-on-exit-flag erc-server-process nil) (should-not erc-dcc-list) (erc-ctcp-query-DCC erc-server-process diff --git a/test/lisp/erc/erc-networks-tests.el b/test/lisp/erc/erc-networks-tests.el index 96836c29aed..b9d216f217b 100644 --- a/test/lisp/erc/erc-networks-tests.el +++ b/test/lisp/erc/erc-networks-tests.el @@ -1475,10 +1475,16 @@ erc-networks--rename-server-buffer--existing--live (erc-mode) (setq erc-network 'FooNet erc-server-current-nick "tester" - erc-insert-marker (set-marker (make-marker) (point-max)) + erc-insert-marker (make-marker) + erc-input-marker (make-marker) erc-server-process (erc-networks-tests--create-live-proc) erc-networks--id (erc-networks--id-create nil)) - (should-not (erc-networks--rename-server-buffer erc-server-process)) + (set-process-sentinel erc-server-process #'ignore) + (erc-display-prompt nil (point-max)) + (set-marker erc-insert-marker (pos-bol)) + (erc-display-message nil 'notice (current-buffer) "notice") + (with-silent-modifications + (should-not (erc-networks--rename-server-buffer erc-server-process))) (should (eq erc-active-buffer old-buf)) (should-not (erc-server-process-alive)) (should (string= (buffer-name) "irc.foonet.org")) diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index 795864a2cc2..b2f24aa718e 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -559,8 +559,8 @@ erc-ring-previous-command ;; (cl-letf (((symbol-function 'erc-process-input-line) (lambda (&rest _) - (insert-before-markers - (erc-display-message-highlight 'notice "echo: one\n")))) + (erc-display-message + nil 'notice (current-buffer) "echo: one\n"))) ((symbol-function 'erc-command-no-process-p) (lambda (&rest _) t))) (ert-info ("Create ring, populate, recall") commit e7992d2adbc50ba8a3b0fb18b9afe22a2a539b1d Author: F. Jason Park Date: Fri Dec 9 22:00:59 2022 -0800 Add option to show visual erc-keep-place indicator * lisp/erc/erc-goodies.el (erc-keep-place-indicator-style, erc-keep-place-indicator-buffer-type, erc-keep-place-indicator-follow): New options for anchoring kept place visually. (erc-keep-place-indicator-line, erc-keep-place-indicator-arrow): New faces. (erc--keep-place-indicator-overlay): New internal variable. (erc--keep-place-indicator-on-window-configuration-change): New function to subscribe to `window-configuration-change-hook' and maybe update kept-place indicator. (erc--keep-place-indicator-setup): New function to initialize buffer for local module `keep-place-indicator'. (erc-keep-place-indicator-mode, erc-keep-place-indicator-enable, erc-keep-place-indicator-disable): New local ERC module. Depends on "parent" module `keep-place'. Like `fill-wrap', this is (for now) also deliberately left out of the widget menu for `erc-modules'. (erc-keep-place-move, erc-keep-place-goto): Add new commands for manually updating and jumping to keep-place indicator. (erc-keep-place): Move `erc--keep-place-overlay' when applicable. * test/lisp/erc/erc-goodies-tests.el (erc-keep-place-indicator-mode): Add test. (Bug#59943.) diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el index 7ea6c42ec65..6235de5f1c0 100644 --- a/lisp/erc/erc-goodies.el +++ b/lisp/erc/erc-goodies.el @@ -32,6 +32,10 @@ (eval-when-compile (require 'cl-lib)) (require 'erc) +(declare-function fringe-columns "fringe" (side &optional real)) +(declare-function pulse-available-p "pulse" nil) +(declare-function pulse-momentary-highlight-overlay "pulse" (o &optional face)) + ;;; Automatically scroll to bottom (defcustom erc-input-line-position nil @@ -143,6 +147,154 @@ keep-place ((add-hook 'erc-insert-pre-hook #'erc-keep-place)) ((remove-hook 'erc-insert-pre-hook #'erc-keep-place))) +(defcustom erc-keep-place-indicator-style t + "Flavor of visual indicator applied to kept place. +For use with the `keep-place-indicator' module. A value of `arrow' +displays an arrow in the left fringe or margin. When it's +`face', ERC adds the face `erc-keep-place-indicator-line' to the +appropriate line. A value of t does both." + :group 'erc + :package-version '(ERC . "5.6") + :type '(choice (const t) (const server) (const target))) + +(defcustom erc-keep-place-indicator-buffer-type t + "ERC buffer type in which to display `keep-place-indicator'. +A value of t means \"all\" ERC buffers." + :group 'erc + :package-version '(ERC . "5.6") + :type '(choice (const t) (const server) (const target))) + +(defcustom erc-keep-place-indicator-follow nil + "Whether to sync visual kept place to window's top when reading. +For use with `erc-keep-place-indicator-mode'." + :group 'erc + :package-version '(ERC . "5.6") + :type 'boolean) + +(defface erc-keep-place-indicator-line + '((((class color) (min-colors 88) (background light) + (supports :underline (:style wave))) + (:underline (:color "PaleGreen3" :style wave))) + (((class color) (min-colors 88) (background dark) + (supports :underline (:style wave))) + (:underline (:color "PaleGreen1" :style wave))) + (t :underline t)) + "Face for option `erc-keep-place-indicator-style'." + :group 'erc-faces) + +(defface erc-keep-place-indicator-arrow + '((((class color) (min-colors 88) (background light)) + (:foreground "PaleGreen3")) + (((class color) (min-colors 88) (background dark)) + (:foreground "PaleGreen1")) + (t :inherit fringe)) + "Face for arrow value of option `erc-keep-place-indicator-style'." + :group 'erc-faces) + +(defvar-local erc--keep-place-indicator-overlay nil + "Overlay for `erc-keep-place-indicator-mode'.") + +(defun erc--keep-place-indicator-on-window-configuration-change () + "Maybe sync `erc--keep-place-indicator-overlay'. +Specifically, do so unless switching to or from another window in +the active frame." + (when erc-keep-place-indicator-follow + (unless (or (minibuffer-window-active-p (minibuffer-window)) + (eq (window-old-buffer) (current-buffer))) + (when (< (overlay-end erc--keep-place-indicator-overlay) + (window-start) + erc-insert-marker) + (erc-keep-place-move (window-start)))))) + +(defun erc--keep-place-indicator-setup () + "Initialize buffer for maintaining `erc--keep-place-indicator-overlay'." + (require 'fringe) + (setq erc--keep-place-indicator-overlay + (if-let* ((vars (or erc--server-reconnecting erc--target-priors)) + ((alist-get 'erc-keep-place-indicator-mode vars))) + (alist-get 'erc--keep-place-indicator-overlay vars) + (make-overlay 0 0))) + (add-hook 'window-configuration-change-hook + #'erc--keep-place-indicator-on-window-configuration-change nil t) + (when-let* (((memq erc-keep-place-indicator-style '(t arrow))) + (display (if (zerop (fringe-columns 'left)) + `((margin left-margin) ,overlay-arrow-string) + '(left-fringe right-triangle + erc-keep-place-indicator-arrow))) + (bef (propertize " " 'display display))) + (overlay-put erc--keep-place-indicator-overlay 'before-string bef)) + (when (memq erc-keep-place-indicator-style '(t face)) + (overlay-put erc--keep-place-indicator-overlay 'face + 'erc-keep-place-indicator-line))) + +;;;###autoload(put 'keep-place-indicator 'erc--feature 'erc-goodies) +(define-erc-module keep-place-indicator nil + "`keep-place' with a fringe arrow and/or highlighted face." + ((unless erc-keep-place-mode + (unless (memq 'keep-place erc-modules) + ;; FIXME use `erc-button--display-error-notice-with-keys' + ;; to display this message when bug#60933 is ready. + (erc-display-error-notice + nil (concat + "Local module `keep-place-indicator' needs module `keep-place'." + " Enabling now. This will affect \C-]all\C-] ERC sessions." + " Add `keep-place' to `erc-modules' to silence this message."))) + (erc-keep-place-mode +1)) + (if (pcase erc-keep-place-indicator-buffer-type + ('target erc--target) + ('server (not erc--target)) + ('t t)) + (erc--keep-place-indicator-setup) + (setq erc-keep-place-indicator-mode nil))) + ((when erc--keep-place-indicator-overlay + (delete-overlay erc--keep-place-indicator-overlay) + (remove-hook 'window-configuration-change-hook + #'erc--keep-place-indicator-on-window-configuration-change t) + (kill-local-variable 'erc--keep-place-indicator-overlay))) + 'local) + +(defun erc-keep-place-move (pos) + "Move keep-place indicator to current line or POS. +For use with `keep-place-indicator' module. When called +interactively, interpret POS as an offset. Specifically, when +POS is a raw prefix arg, like (4), move the indicator to the +window's last line. When it's the minus sign, put it on the +window's first line. Interpret an integer as an offset in lines." + (interactive + (progn + (unless erc-keep-place-indicator-mode + (user-error "`erc-keep-place-indicator-mode' not enabled")) + (list (pcase current-prefix-arg + ((and (pred integerp) v) + (save-excursion + (let ((inhibit-field-text-motion t)) + (forward-line v) + (point)))) + (`(,_) (1- (min erc-insert-marker (window-end)))) + ('- (min (1- erc-insert-marker) (window-start))))))) + (save-excursion + (let ((inhibit-field-text-motion t)) + (when pos + (goto-char pos)) + (move-overlay erc--keep-place-indicator-overlay + (line-beginning-position) + (line-end-position))))) + +(defun erc-keep-place-goto () + "Jump to keep-place indicator. +For use with `keep-place-indicator' module." + (interactive + (prog1 nil + (unless erc-keep-place-indicator-mode + (user-error "`erc-keep-place-indicator-mode' not enabled")) + (deactivate-mark) + (push-mark))) + (goto-char (overlay-start erc--keep-place-indicator-overlay)) + (recenter (truncate (* (window-height) 0.25)) t) + (require 'pulse) + (when (pulse-available-p) + (pulse-momentary-highlight-overlay erc--keep-place-indicator-overlay))) + (defun erc-keep-place (_ignored) "Move point away from the last line in a non-selected ERC buffer." (when (and (not (eq (window-buffer (selected-window)) @@ -151,6 +303,11 @@ erc-keep-place (deactivate-mark) (goto-char (erc-beg-of-input-line)) (forward-line -1) + (when erc-keep-place-indicator-mode + (unless (or (minibuffer-window-active-p (selected-window)) + (and (frame-visible-p (selected-frame)) + (get-buffer-window (current-buffer) (selected-frame)))) + (erc-keep-place-move nil))) ;; if `switch-to-buffer-preserve-window-point' is set, ;; we cannot rely on point being saved, and must commit ;; it to window-prev-buffers. diff --git a/test/lisp/erc/erc-goodies-tests.el b/test/lisp/erc/erc-goodies-tests.el index 46fcf82401b..a1f53c5bf88 100644 --- a/test/lisp/erc/erc-goodies-tests.el +++ b/test/lisp/erc/erc-goodies-tests.el @@ -250,4 +250,85 @@ erc-controls-highlight--motd (when noninteractive (kill-buffer))))) + +;; Among other things, this test also asserts that a local module's +;; minor-mode toggle is allowed to disable its mode variable as +;; needed. + +(ert-deftest erc-keep-place-indicator-mode () + ;; FIXME remove after adding + (unless (fboundp 'erc--initialize-markers) + (ert-skip "Missing required function")) + (with-current-buffer (get-buffer-create "*erc-keep-place-indicator-mode*") + (erc-mode) + (erc--initialize-markers (point) nil) + (let ((assert-off + (lambda () + (should-not erc-keep-place-indicator-mode) + (should-not (local-variable-p 'window-configuration-change-hook)) + (should-not erc--keep-place-indicator-overlay))) + (assert-on + (lambda () + (should erc--keep-place-indicator-overlay) + (should (local-variable-p 'window-configuration-change-hook)) + (should window-configuration-change-hook) + (should erc-keep-place-mode))) + ;; + erc-insert-pre-hook + erc-modules) + + (funcall assert-off) + + (ert-info ("Value t") + (should (eq erc-keep-place-indicator-buffer-type t)) + (erc-keep-place-indicator-mode +1) + (funcall assert-on) + (goto-char (point-min)) + (should (search-forward "Enabling" nil t)) + (should (memq 'keep-place erc-modules))) + + (erc-keep-place-indicator-mode -1) + (funcall assert-off) + + (ert-info ("Value `target'") + (let ((erc-keep-place-indicator-buffer-type 'target)) + (erc-keep-place-indicator-mode +1) + (funcall assert-off) + (setq erc--target (erc--target-from-string "#chan")) + (erc-keep-place-indicator-mode +1) + (funcall assert-on))) + + (erc-keep-place-indicator-mode -1) + (funcall assert-off) + + (ert-info ("Value `server'") + (let ((erc-keep-place-indicator-buffer-type 'server)) + (erc-keep-place-indicator-mode +1) + (funcall assert-off) + (setq erc--target nil) + (erc-keep-place-indicator-mode +1) + (funcall assert-on))) + + ;; Populate buffer + (erc-display-message nil 'notice (current-buffer) + "This buffer is for text that is not saved") + (erc-display-message nil 'notice (current-buffer) + "and for lisp evaluation") + (should (search-forward "saved" nil t)) + (erc-keep-place-move nil) + (goto-char erc-input-marker) + + (ert-info ("Indicator survives reconnect") + (let ((erc--server-reconnecting (buffer-local-variables))) + (cl-letf (((symbol-function 'erc-server-connect) #'ignore)) + (erc-open "localhost" 6667 "tester" "Tester" 'connect + nil nil nil nil nil "tester" nil))) + (funcall assert-on) + (should (= (point) erc-input-marker)) + (goto-char (overlay-start erc--keep-place-indicator-overlay)) + (should (looking-at (rx "*** This buffer is for text"))))) + + (when noninteractive + (kill-buffer)))) + ;;; erc-goodies-tests.el ends here commit ba7fe88b782ad516b4cbb5e99fb108f57a9235e2 Author: F. Jason Park Date: Thu Dec 29 06:43:19 2022 -0800 Optionally prompt for more ERC entry-point params * doc/misc/erc.texi: Update statement about availability of `:user' keyword param when entry points called interactively. * lisp/erc/erc/compat.el: Don't require `url-parse' when compiling. Add forward declaration for `url-type'. * lisp/erc/erc.el: Don't require `url-parse' when compiling. Add forward declarations for accessors of `url' struct from `url-parse' library. (erc-select-read-args): Allow optionally calling entry points with a prefix arg to access params `user' and `:full-name'. (erc-tls): Update doc string. * test/lisp/erc/erc-tests.el (erc-select-read-args): Add test for extra args. (Bug#60428.) diff --git a/doc/misc/erc.texi b/doc/misc/erc.texi index b80affbc954..e92bf576e75 100644 --- a/doc/misc/erc.texi +++ b/doc/misc/erc.texi @@ -952,7 +952,7 @@ SASL 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. +@code{erc-tls}. @item @code{external} (via Client TLS Certificate) This works in conjunction with the @code{:client-certificate} keyword diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el index 10a495211cc..29892b78a39 100644 --- a/lisp/erc/erc-compat.el +++ b/lisp/erc/erc-compat.el @@ -32,7 +32,7 @@ ;;; Code: (require 'compat nil 'noerror) -(eval-when-compile (require 'cl-lib) (require 'url-parse)) +(eval-when-compile (require 'cl-lib)) ;; Except for the "erc-" namespacing, these two definitions should be ;; continuously updated to match the latest upstream ones verbatim. @@ -412,6 +412,7 @@ erc-compat--29-sasl-scram--client-final-message ;;;; Misc 29.1 (defvar url-irc-function) +(declare-function url-type "url-parse" (cl-x)) (defun erc-compat--29-browse-url-irc (string &rest _) (require 'url-irc) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 4c856f49c04..85f0416f44b 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -65,7 +65,7 @@ (require 'cl-lib) (require 'format-spec) (require 'auth-source) -(eval-when-compile (require 'subr-x) (require 'url-parse)) +(eval-when-compile (require 'subr-x)) (defconst erc-version "5.6-git" "This version of ERC.") @@ -142,6 +142,12 @@ gtk-version-string (declare-function word-at-point "thingatpt" (&optional no-properties)) (autoload 'word-at-point "thingatpt") ; for hl-nicks +(declare-function url-host "url-parse" (cl-x)) +(declare-function url-password "url-parse" (cl-x)) +(declare-function url-portspec "url-parse" (cl-x)) +(declare-function url-type "url-parse" (cl-x)) +(declare-function url-user "url-parse" (cl-x)) + ;; tunable connection and authentication parameters (defcustom erc-server nil @@ -2257,8 +2263,8 @@ erc--ensure-url ;;;###autoload (defun erc-select-read-args () - "Prompt the user for values of nick, server, port, and password." - (require 'url-parse) + "Prompt the user for values of nick, server, port, and password. +With prefix arg, also prompt for user and full name." (let* ((input (let ((d (erc-compute-server))) (read-string (format "Server or URL (default is %S): " d) nil 'erc-server-history-list d))) @@ -2278,6 +2284,14 @@ erc-select-read-args (let ((d (erc-compute-nick))) (read-string (format "Nickname (default is %S): " d) nil 'erc-nick-history-list d)))) + (user (and current-prefix-arg + (let ((d (erc-compute-user (url-user url)))) + (read-string (format "User (default is %S): " d) + nil nil d)))) + (full (and current-prefix-arg + (let ((d (erc-compute-full-name (url-user url)))) + (read-string (format "Full name (default is %S): " d) + nil nil d)))) (passwd (let* ((p (with-suppressed-warnings ((obsolete erc-password)) (or (url-password url) erc-password))) (m (if p @@ -2298,8 +2312,8 @@ erc-select-read-args (push `(erc-server-connect-function . ,opener) env)) (when (and passwd (string= "" passwd)) (setq passwd nil)) - `( :server ,server :port ,port :nick ,nick - ,@(and passwd `(:password ,passwd)) + `( :server ,server :port ,port :nick ,nick ,@(and user `(:user ,user)) + ,@(and passwd `(:password ,passwd)) ,@(and full `(:full-name ,full)) ,@(and env `(&interactive-env ,env))))) (defmacro erc--with-entrypoint-environment (env &rest body) @@ -2407,8 +2421,8 @@ erc-tls When present, ID should be a symbol or a string to use for naming the server buffer and identifying the connection unequivocally. -See Info node `(erc) Network Identifier' for details. Like USER -and CLIENT-CERTIFICATE, this parameter cannot be specified +See Info node `(erc) Network Identifier' for details. Like +CLIENT-CERTIFICATE, this parameter cannot be specified interactively. \(fn &key SERVER PORT NICK USER PASSWORD FULL-NAME CLIENT-CERTIFICATE ID)" diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index beb4b4cef76..795864a2cc2 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -1161,7 +1161,18 @@ erc-select-read-args (erc-select-read-args)) (list :server "[::1]" :port 6667 - :nick "nick"))))) + :nick "nick")))) + + (ert-info ("Extra args use URL nick by default") + (should (equal (ert-simulate-keys "nick:sesame@localhost:6667\r\r\r\r" + (let ((current-prefix-arg '(4))) + (erc-select-read-args))) + (list :server "localhost" + :port 6667 + :nick "nick" + :user "nick" + :password "sesame" + :full-name "nick"))))) (ert-deftest erc-tls () (let (calls env) commit 3a012d1db24d613814296139c98324df1d7ef71f Author: F. Jason Park Date: Thu Dec 29 06:43:19 2022 -0800 Add display option for interactive ERC invocations * lisp/erc/erc.el (erc-buffer-display, erc-receive-query-display): Add aliases for `erc-join-buffer' and `erc-auto-query'. (erc-interactive-display): Add new option to control display of server buffers during interactive entry-point invocations. (erc-select-read-args): Pass `erc-interactive-display' to entry points. * test/lisp/erc/erc-tests.el (erc-select-read-args): Expect buffer-display values from `erc-interactive-display'. (erc-tls, erc--interactive): Also check `erc-join-buffer' in environment when `erc-open' called. (Bug#60428.) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index e1abfee9ba3..4c856f49c04 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -1501,6 +1501,7 @@ erc-default-port-tls "IRC port to use for encrypted connections if it cannot be \ detected otherwise.") +(defvaralias 'erc-buffer-display 'erc-join-buffer) (defcustom erc-join-buffer 'bury "Determines how to display a newly created IRC buffer. @@ -1521,6 +1522,19 @@ erc-join-buffer (const :tag "Use current buffer" buffer) (const :tag "Use current buffer" t))) +(defcustom erc-interactive-display 'buffer + "How and whether to display server buffers for M-x erc. +See `erc-buffer-display' and friends for a description of +possible values." + :package-version '(ERC . "5.6") ; FIXME sync on release + :group 'erc-buffers + :type '(choice (const :tag "Use value of `erc-join-buffer'" nil) + (const :tag "Split window and select" window) + (const :tag "Split window, don't select" window-noselect) + (const :tag "New frame" frame) + (const :tag "Bury new and don't display existing" bury) + (const :tag "Use current buffer" buffer))) + (defcustom erc-reconnect-display nil "How (and whether) to display a channel buffer upon reconnecting. @@ -2278,6 +2292,8 @@ erc-select-read-args (setq port erc-default-port-tls))) #'erc-open-tls-stream)) env) + (when erc-interactive-display + (push `(erc-join-buffer . ,erc-interactive-display) env)) (when opener (push `(erc-server-connect-function . ,opener) env)) (when (and passwd (string= "" passwd)) @@ -4610,6 +4626,7 @@ erc-query (with-current-buffer server-buffer (erc--open-target target))) +(defvaralias 'erc-receive-query-display 'erc-auto-query) (defcustom erc-auto-query 'window-noselect "If non-nil, create a query buffer each time you receive a private message. If the buffer doesn't already exist, it is created. diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index c5905ab4f67..beb4b4cef76 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -1079,8 +1079,9 @@ erc-select-read-args (list :server "irc.libera.chat" :port 6697 :nick (user-login-name) - '&interactive-env '((erc-server-connect-function - . erc-open-tls-stream)))))) + '&interactive-env + '((erc-server-connect-function . erc-open-tls-stream) + (erc-join-buffer . buffer)))))) (ert-info ("Switches to TLS when port matches default TLS port") (should (equal (ert-simulate-keys "irc.gnu.org\r6697\r\r\r" @@ -1088,8 +1089,9 @@ erc-select-read-args (list :server "irc.gnu.org" :port 6697 :nick (user-login-name) - '&interactive-env '((erc-server-connect-function - . erc-open-tls-stream)))))) + '&interactive-env + '((erc-server-connect-function . erc-open-tls-stream) + (erc-join-buffer . buffer)))))) (ert-info ("Switches to TLS when URL is ircs://") (should (equal (ert-simulate-keys "ircs://irc.gnu.org\r\r\r\r" @@ -1097,8 +1099,11 @@ erc-select-read-args (list :server "irc.gnu.org" :port 6697 :nick (user-login-name) - '&interactive-env '((erc-server-connect-function - . erc-open-tls-stream)))))) + '&interactive-env + '((erc-server-connect-function . erc-open-tls-stream) + (erc-join-buffer . buffer)))))) + + (setq-local erc-interactive-display nil) ; cheat to save space (ert-info ("Opt out of non-TLS warning manually") (should (equal (ert-simulate-keys "\r\r\r\rn\r" @@ -1164,7 +1169,8 @@ erc-tls (lambda (&optional _) "tester")) ((symbol-function 'erc-open) (lambda (&rest r) - (push `((erc-server-connect-function + (push `((erc-join-buffer ,erc-join-buffer) + (erc-server-connect-function ,erc-server-connect-function)) env) (push r calls)))) @@ -1175,7 +1181,8 @@ erc-tls '("irc.libera.chat" 6697 "tester" "unknown" t nil nil nil nil nil "user" nil))) (should (equal (pop env) - '((erc-server-connect-function erc-open-tls-stream))))) + '((erc-join-buffer bury) + (erc-server-connect-function erc-open-tls-stream))))) (ert-info ("Full") (erc-tls :server "irc.gnu.org" @@ -1190,7 +1197,8 @@ erc-tls '("irc.gnu.org" 7000 "bob" "Bob's Name" t "bob:changeme" nil nil nil t "bobo" GNU.org))) (should (equal (pop env) - '((erc-server-connect-function erc-open-tls-stream))))) + '((erc-join-buffer bury) + (erc-server-connect-function erc-open-tls-stream))))) ;; Values are often nil when called by lisp code, which leads to ;; null params. This is why `erc-open' recomputes almost @@ -1208,7 +1216,8 @@ erc-tls '(nil 7000 nil "Bob's Name" t "bob:changeme" nil nil nil nil "bobo" nil))) (should (equal (pop env) - '((erc-server-connect-function erc-open-tls-stream))))) + '((erc-join-buffer bury) + (erc-server-connect-function erc-open-tls-stream))))) (ert-info ("Interactive") (ert-simulate-keys "nick:sesame@localhost:6667\r\r" @@ -1217,8 +1226,8 @@ erc-tls '("localhost" 6667 "nick" "unknown" t "sesame" nil nil nil nil "user" nil))) (should (equal (pop env) - '((erc-server-connect-function - erc-open-tls-stream))))) + '((erc-join-buffer buffer) + (erc-server-connect-function erc-open-tls-stream))))) (ert-info ("Custom connect function") (let ((erc-server-connect-function 'my-connect-func)) @@ -1227,7 +1236,8 @@ erc-tls '("irc.libera.chat" 6697 "tester" "unknown" t nil nil nil nil nil "user" nil))) (should (equal (pop env) - '((erc-server-connect-function my-connect-func)))))) + '((erc-join-buffer bury) + (erc-server-connect-function my-connect-func)))))) (ert-info ("Advised default function overlooked") ; intentional (advice-add 'erc-server-connect-function :around #'ignore @@ -1237,7 +1247,8 @@ erc-tls '("irc.libera.chat" 6697 "tester" "unknown" t nil nil nil nil nil "user" nil))) (should (equal (pop env) - '((erc-server-connect-function erc-open-tls-stream)))) + '((erc-join-buffer bury) + (erc-server-connect-function erc-open-tls-stream)))) (advice-remove 'erc-server-connect-function 'erc-tests--erc-tls)) (ert-info ("Advised non-default function honored") @@ -1249,7 +1260,8 @@ erc-tls (should (equal (pop calls) '("irc.libera.chat" 6697 "tester" "unknown" t nil nil nil nil nil "user" nil))) - (should (equal (pop env) `((erc-server-connect-function ,f)))) + (should (equal (pop env) `((erc-join-buffer bury) + (erc-server-connect-function ,f)))) (advice-remove 'erc-server-connect-function 'erc-tests--erc-tls))))))) @@ -1262,7 +1274,8 @@ erc--interactive (lambda (&optional _) "tester")) ((symbol-function 'erc-open) (lambda (&rest r) - (push `((erc-server-connect-function + (push `((erc-join-buffer ,erc-join-buffer) + (erc-server-connect-function ,erc-server-connect-function)) env) (push r calls)))) @@ -1274,7 +1287,8 @@ erc--interactive '("irc.libera.chat" 6697 "tester" "unknown" t nil nil nil nil nil "user" nil))) (should (equal (pop env) - '((erc-server-connect-function erc-open-tls-stream))))) + '((erc-join-buffer buffer) (erc-server-connect-function + erc-open-tls-stream))))) (ert-info ("Nick supplied, decline TLS upgrade") (ert-simulate-keys "\r\rdummy\r\rn\r" @@ -1283,7 +1297,7 @@ erc--interactive '("irc.libera.chat" 6667 "dummy" "unknown" t nil nil nil nil nil "user" nil))) (should (equal (pop env) - '( + '((erc-join-buffer buffer) (erc-server-connect-function erc-open-network-stream)))))))) commit 0f7fc5cfdf97a8280ea8f012e50af9e615e8c6ef Author: F. Jason Park Date: Thu Dec 29 06:43:19 2022 -0800 Be smarter about switching to TLS from M-x erc * lisp/erc/erc.el (erc--warn-unencrypted): Remove unused internal function. (erc-select-read-args): Offer to use TLS when user runs M-x erc and opts for default server and port or provides the well-known IANA TLS port or enters an ircs:// URL at the server prompt. For the last two, do this immediately instead of calling `erc-tls' interactively and imposing a review of just-chosen values. Also remove error warnings and ensure `erc-tls' still works by setting `erc-server-connect-function' to `erc-open-tls-stream' when appropriate. Include the word "URL" in server prompt. (erc--with-entrypoint-environment): Add new macro for empowering an entry point's interactive form to bind special variables in their command's body without shadowing them in the lambda list. (erc, erc-tls): Add internal keyword argument for interactive use, but don't make it `keywordp' or advertise its presence. Also use new helper macro, `erc--with-entrypoint-environment', to temporarily bind special vars given by interactive helper `erc-select-read-args'. * test/lisp/erc/erc-tests.el (erc--with-entrypoint-environment): Add new test. (erc-select-read-args): Modify return values to expect additional internal keyword argument where appropriate. (erc-tls): Make assertions about environment. (erc--interactive): New test. (Bug#60428.) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index ea581c17661..e1abfee9ba3 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -2241,29 +2241,12 @@ erc--ensure-url (setq input (concat "irc://" input))) input) -;; A temporary means of addressing the problem of ERC's namesake entry -;; point defaulting to a non-TLS connection with its default server -;; (bug#60428). -(defun erc--warn-unencrypted () - ;; Remove unconditionally to avoid wrong context due to races from - ;; simultaneous dialing or aborting (e.g., via `keybaord-quit'). - (remove-hook 'erc--server-post-connect-hook #'erc--warn-unencrypted) - (when (and (process-contact erc-server-process :nowait) - (equal erc-session-server erc-default-server) - (eql erc-session-port erc-default-port)) - ;; FIXME use the autoloaded `info' instead of `Info-goto-node' in - ;; `erc-button-alist'. - (require 'info nil t) - (erc-display-error-notice - nil (concat "This connection is unencrypted. Please use `erc-tls'" - " from now on. See Info:\"(erc) connecting\" for more.")))) - ;;;###autoload (defun erc-select-read-args () "Prompt the user for values of nick, server, port, and password." (require 'url-parse) (let* ((input (let ((d (erc-compute-server))) - (read-string (format "Server (default is %S): " d) + (read-string (format "Server or URL (default is %S): " d) nil 'erc-server-history-list d))) ;; For legacy reasons, also accept a URL without a scheme. (url (url-generic-parse-url (erc--ensure-url input))) @@ -2286,15 +2269,32 @@ erc-select-read-args (m (if p (format "Server password (default is %S): " p) "Server password (optional): "))) - (if erc-prompt-for-password (read-passwd m nil p) p)))) + (if erc-prompt-for-password (read-passwd m nil p) p))) + (opener (and (or sp (eql port erc-default-port-tls) + (and (equal server erc-default-server) + (not (string-prefix-p "irc://" input)) + (eql port erc-default-port) + (y-or-n-p "Connect using TLS instead? ") + (setq port erc-default-port-tls))) + #'erc-open-tls-stream)) + env) + (when opener + (push `(erc-server-connect-function . ,opener) env)) (when (and passwd (string= "" passwd)) (setq passwd nil)) - (when (and (equal server erc-default-server) - (eql port erc-default-port) - (not (eql port erc-default-port-tls)) ; not `erc-tls' - (not (string-prefix-p "irc://" input))) ; not yanked URL - (add-hook 'erc--server-post-connect-hook #'erc--warn-unencrypted)) - (list :server server :port port :nick nick :password passwd))) + `( :server ,server :port ,port :nick ,nick + ,@(and passwd `(:password ,passwd)) + ,@(and env `(&interactive-env ,env))))) + +(defmacro erc--with-entrypoint-environment (env &rest body) + "Run BODY with bindings from ENV alist." + (declare (indent 1)) + (let ((syms (make-symbol "syms")) + (vals (make-symbol "vals"))) + `(let (,syms ,vals) + (pcase-dolist (`(,k . ,v) ,env) (push k ,syms) (push v ,vals)) + (cl-progv ,syms ,vals + ,@body)))) ;;;###autoload (cl-defun erc (&key (server (erc-compute-server)) @@ -2303,7 +2303,9 @@ erc (user (erc-compute-user)) password (full-name (erc-compute-full-name)) - id) + id + ;; Used by interactive form + ((&interactive-env --interactive-env--))) "ERC is a powerful, modular, and extensible IRC client. This function is the main entry point for ERC. @@ -2326,9 +2328,12 @@ erc whereas `erc-compute-port' and `erc-compute-nick' will be invoked for the values of the other parameters. -See `erc-tls' for the meaning of ID." +See `erc-tls' for the meaning of ID. + +\(fn &key SERVER PORT NICK USER PASSWORD FULL-NAME ID)" (interactive (erc-select-read-args)) - (erc-open server port nick full-name t password nil nil nil nil user id)) + (erc--with-entrypoint-environment --interactive-env-- + (erc-open server port nick full-name t password nil nil nil nil user id))) ;;;###autoload (defalias 'erc-select #'erc) @@ -2342,7 +2347,9 @@ erc-tls password (full-name (erc-compute-full-name)) client-certificate - id) + id + ;; Used by interactive form + ((&interactive-env --interactive-env--))) "ERC is a powerful, modular, and extensible IRC client. This function is the main entry point for ERC over TLS. @@ -2386,10 +2393,20 @@ erc-tls the server buffer and identifying the connection unequivocally. See Info node `(erc) Network Identifier' for details. Like USER and CLIENT-CERTIFICATE, this parameter cannot be specified -interactively." +interactively. + +\(fn &key SERVER PORT NICK USER PASSWORD FULL-NAME CLIENT-CERTIFICATE ID)" (interactive (let ((erc-default-port erc-default-port-tls)) (erc-select-read-args))) - (let ((erc-server-connect-function 'erc-open-tls-stream)) + ;; Bind `erc-server-connect-function' to `erc-open-tls-stream' + ;; around `erc-open' when a non-default value hasn't been specified + ;; by the user or the interactive form. And don't bother checking + ;; for advice, indirect functions, autoloads, etc. + (unless (or (assq 'erc-server-connect-function --interactive-env--) + (not (eq erc-server-connect-function #'erc-open-network-stream))) + (push '(erc-server-connect-function . erc-open-tls-stream) + --interactive-env--)) + (erc--with-entrypoint-environment --interactive-env-- (erc-open server port nick full-name t password nil nil nil client-certificate user id))) diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index ae19b7d0aad..c5905ab4f67 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -1064,32 +1064,62 @@ erc--server-connect-dumb-ipv6-regexp (should (string-match erc--server-connect-dumb-ipv6-regexp (concat "[" a "]"))))) +(ert-deftest erc--with-entrypoint-environment () + (let ((env '((erc-join-buffer . foo) + (erc-server-connect-function . bar)))) + (erc--with-entrypoint-environment env + (should (eq erc-join-buffer 'foo)) + (should (eq erc-server-connect-function 'bar))))) + (ert-deftest erc-select-read-args () - (ert-info ("Does not default to TLS") - (should (equal (ert-simulate-keys "\r\r\r\r" + (ert-info ("Prompts for switch to TLS by default") + (should (equal (ert-simulate-keys "\r\r\r\ry\r" (erc-select-read-args)) (list :server "irc.libera.chat" - :port 6667 + :port 6697 + :nick (user-login-name) + '&interactive-env '((erc-server-connect-function + . erc-open-tls-stream)))))) + + (ert-info ("Switches to TLS when port matches default TLS port") + (should (equal (ert-simulate-keys "irc.gnu.org\r6697\r\r\r" + (erc-select-read-args)) + (list :server "irc.gnu.org" + :port 6697 + :nick (user-login-name) + '&interactive-env '((erc-server-connect-function + . erc-open-tls-stream)))))) + + (ert-info ("Switches to TLS when URL is ircs://") + (should (equal (ert-simulate-keys "ircs://irc.gnu.org\r\r\r\r" + (erc-select-read-args)) + (list :server "irc.gnu.org" + :port 6697 :nick (user-login-name) - :password nil)))) + '&interactive-env '((erc-server-connect-function + . erc-open-tls-stream)))))) + + (ert-info ("Opt out of non-TLS warning manually") + (should (equal (ert-simulate-keys "\r\r\r\rn\r" + (erc-select-read-args)) + (list :server "irc.libera.chat" + :port 6667 + :nick (user-login-name))))) (ert-info ("Override default TLS") (should (equal (ert-simulate-keys "irc://irc.libera.chat\r\r\r\r" (erc-select-read-args)) (list :server "irc.libera.chat" :port 6667 - :nick (user-login-name) - :password nil)))) + :nick (user-login-name))))) (ert-info ("Address includes port") - (should (equal (ert-simulate-keys - "localhost:6667\rnick\r\r" + (should (equal (ert-simulate-keys "localhost:6667\rnick\r\r" (erc-select-read-args)) (list :server "localhost" :port 6667 - :nick "nick" - :password nil)))) + :nick "nick")))) (ert-info ("Address includes nick, password skipped via option") (should (equal (ert-simulate-keys "nick@localhost:6667\r" @@ -1097,8 +1127,7 @@ erc-select-read-args (erc-select-read-args))) (list :server "localhost" :port 6667 - :nick "nick" - :password nil)))) + :nick "nick")))) (ert-info ("Address includes nick and password") (should (equal (ert-simulate-keys "nick:sesame@localhost:6667\r\r" @@ -1113,37 +1142,40 @@ erc-select-read-args (erc-select-read-args)) (list :server "[::1]" :port 6667 - :nick (user-login-name) - :password nil)))) + :nick (user-login-name))))) (ert-info ("IPv6 address with port") (should (equal (ert-simulate-keys "[::1]:6667\r\r\r" (erc-select-read-args)) (list :server "[::1]" :port 6667 - :nick (user-login-name) - :password nil)))) + :nick (user-login-name))))) (ert-info ("IPv6 address includes nick") (should (equal (ert-simulate-keys "nick@[::1]:6667\r\r" (erc-select-read-args)) (list :server "[::1]" :port 6667 - :nick "nick" - :password nil))))) + :nick "nick"))))) (ert-deftest erc-tls () - (let (calls) + (let (calls env) (cl-letf (((symbol-function 'user-login-name) (lambda (&optional _) "tester")) ((symbol-function 'erc-open) - (lambda (&rest r) (push r calls)))) + (lambda (&rest r) + (push `((erc-server-connect-function + ,erc-server-connect-function)) + env) + (push r calls)))) (ert-info ("Defaults") (erc-tls) (should (equal (pop calls) '("irc.libera.chat" 6697 "tester" "unknown" t - nil nil nil nil nil "user" nil)))) + nil nil nil nil nil "user" nil))) + (should (equal (pop env) + '((erc-server-connect-function erc-open-tls-stream))))) (ert-info ("Full") (erc-tls :server "irc.gnu.org" @@ -1156,7 +1188,9 @@ erc-tls :id 'GNU.org) (should (equal (pop calls) '("irc.gnu.org" 7000 "bob" "Bob's Name" t - "bob:changeme" nil nil nil t "bobo" GNU.org)))) + "bob:changeme" nil nil nil t "bobo" GNU.org))) + (should (equal (pop env) + '((erc-server-connect-function erc-open-tls-stream))))) ;; Values are often nil when called by lisp code, which leads to ;; null params. This is why `erc-open' recomputes almost @@ -1172,7 +1206,86 @@ erc-tls :password "bob:changeme")) (should (equal (pop calls) '(nil 7000 nil "Bob's Name" t - "bob:changeme" nil nil nil nil "bobo" nil))))))) + "bob:changeme" nil nil nil nil "bobo" nil))) + (should (equal (pop env) + '((erc-server-connect-function erc-open-tls-stream))))) + + (ert-info ("Interactive") + (ert-simulate-keys "nick:sesame@localhost:6667\r\r" + (call-interactively #'erc-tls)) + (should (equal (pop calls) + '("localhost" 6667 "nick" "unknown" t "sesame" + nil nil nil nil "user" nil))) + (should (equal (pop env) + '((erc-server-connect-function + erc-open-tls-stream))))) + + (ert-info ("Custom connect function") + (let ((erc-server-connect-function 'my-connect-func)) + (erc-tls) + (should (equal (pop calls) + '("irc.libera.chat" 6697 "tester" "unknown" t + nil nil nil nil nil "user" nil))) + (should (equal (pop env) + '((erc-server-connect-function my-connect-func)))))) + + (ert-info ("Advised default function overlooked") ; intentional + (advice-add 'erc-server-connect-function :around #'ignore + '((name . erc-tests--erc-tls))) + (erc-tls) + (should (equal (pop calls) + '("irc.libera.chat" 6697 "tester" "unknown" t + nil nil nil nil nil "user" nil))) + (should (equal (pop env) + '((erc-server-connect-function erc-open-tls-stream)))) + (advice-remove 'erc-server-connect-function 'erc-tests--erc-tls)) + + (ert-info ("Advised non-default function honored") + (let ((f (lambda (&rest r) (ignore r)))) + (cl-letf (((symbol-value 'erc-server-connect-function) f)) + (advice-add 'erc-server-connect-function :around #'ignore + '((name . erc-tests--erc-tls))) + (erc-tls) + (should (equal (pop calls) + '("irc.libera.chat" 6697 "tester" "unknown" t + nil nil nil nil nil "user" nil))) + (should (equal (pop env) `((erc-server-connect-function ,f)))) + (advice-remove 'erc-server-connect-function + 'erc-tests--erc-tls))))))) + +;; See `erc-select-read-args' above for argument parsing. +;; This only tests the "hidden" arguments. + +(ert-deftest erc--interactive () + (let (calls env) + (cl-letf (((symbol-function 'user-login-name) + (lambda (&optional _) "tester")) + ((symbol-function 'erc-open) + (lambda (&rest r) + (push `((erc-server-connect-function + ,erc-server-connect-function)) + env) + (push r calls)))) + + (ert-info ("Default click-through accept TLS upgrade") + (ert-simulate-keys "\r\r\r\ry\r" + (call-interactively #'erc)) + (should (equal (pop calls) + '("irc.libera.chat" 6697 "tester" "unknown" t nil + nil nil nil nil "user" nil))) + (should (equal (pop env) + '((erc-server-connect-function erc-open-tls-stream))))) + + (ert-info ("Nick supplied, decline TLS upgrade") + (ert-simulate-keys "\r\rdummy\r\rn\r" + (call-interactively #'erc)) + (should (equal (pop calls) + '("irc.libera.chat" 6667 "dummy" "unknown" t nil + nil nil nil nil "user" nil))) + (should (equal (pop env) + '( + (erc-server-connect-function + erc-open-network-stream)))))))) (defun erc-tests--make-server-buf (name) (with-current-buffer (get-buffer-create name) commit 8dd209eea47f3b8e1fce6dc12c13d33da1154d89 Author: F. Jason Park Date: Tue Jan 3 23:10:53 2023 -0800 Ignore killed buffers when switching in erc-track * lisp/erc/erc-track.el (erc-track--switch-buffer): If the chosen buffer has been killed, remove it from `erc-modified-channels-alist' and try again. * test/lisp/erc/erc-scenarios-misc.el (erc-scenarios-base-kill-server-track): New test. (Bug#60560.) diff --git a/lisp/erc/erc-track.el b/lisp/erc/erc-track.el index 7fd7b53602e..e060b7039bd 100644 --- a/lisp/erc/erc-track.el +++ b/lisp/erc/erc-track.el @@ -921,7 +921,11 @@ erc-track--switch-buffer (unless (eq major-mode 'erc-mode) (setq erc-track-last-non-erc-buffer (current-buffer))) ;; and jump to the next active channel - (funcall fun (erc-track-get-active-buffer arg))) + (if-let ((buf (erc-track-get-active-buffer arg)) + ((buffer-live-p buf))) + (funcall fun buf) + (erc-modified-channels-update) + (erc-track--switch-buffer fun arg))) ;; if no active channels, switch back to what we were doing before ((and erc-track-last-non-erc-buffer erc-track-switch-from-erc diff --git a/test/lisp/erc/erc-scenarios-misc.el b/test/lisp/erc/erc-scenarios-misc.el index 5927eee48fd..bb925eed836 100644 --- a/test/lisp/erc/erc-scenarios-misc.el +++ b/test/lisp/erc/erc-scenarios-misc.el @@ -205,4 +205,38 @@ erc-scenarios-handle-irc-url (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) (funcall expect 10 "welcome"))))) +;; Ensure that ERC does not attempt to switch to a killed server +;; buffer via `erc-track-switch-buffer'. + +(declare-function erc-track-switch-buffer "erc-track" (arg)) +(defvar erc-track-mode) + +(ert-deftest erc-scenarios-base-kill-server-track () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "networks/merge-server") + (dumb-server (erc-d-run "localhost" t 'track)) + (port (process-contact dumb-server :service)) + (erc-server-flood-penalty 0.1) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester") + (should (string= (buffer-name) (format "127.0.0.1:%d" port))) + (should erc-track-mode) + (funcall expect 5 "changed mode for tester") + (erc-cmd-JOIN "#chan"))) + + (ert-info ("Join channel and kill server buffer") + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#chan")) + (funcall expect 5 "The hour that fools should ask")) + (with-current-buffer "FooNet" + (set-process-query-on-exit-flag erc-server-process nil) + (kill-buffer)) + (should-not (eq (current-buffer) (get-buffer "#chan"))) ; *temp* + (ert-simulate-command '(erc-track-switch-buffer 1)) ; No longer signals + (should (eq (current-buffer) (get-buffer "#chan")))))) + ;;; erc-scenarios-misc.el ends here commit 39d4f32fc9b87598ed6070d300d5b5e17e7ea84f Author: F. Jason Park Date: Mon Jan 16 20:18:32 2023 -0800 Fill doc strings for ERC modules * lisp/erc/erc-common.el (erc--fill-module-docstring): Add helper to fill doc strings. (erc--assemble-toggle, define-erc-module): Use helper to fill doc string. * test/lisp/erc/erc-tests.el (define-minor-mode--global, define-minor-mode--local): Adjust expected output for generated doc strings. (Bug#60935.) diff --git a/lisp/erc/erc-common.el b/lisp/erc/erc-common.el index c01c0323453..8b23904cb99 100644 --- a/lisp/erc/erc-common.el +++ b/lisp/erc/erc-common.el @@ -136,7 +136,7 @@ erc--favor-changed-reverted-modules-state (defun erc--assemble-toggle (localp name ablsym mode val body) (let ((arg (make-symbol "arg"))) `(defun ,ablsym ,(if localp `(&optional ,arg) '()) - ,(concat + ,(erc--fill-module-docstring (if val "Enable" "Disable") " ERC " (symbol-name name) " mode." (when localp @@ -250,6 +250,20 @@ erc--prepare-custom-module-type (if hasp "from" "to") " `erc-modules'."))) :action ,(apply-partially #'erc--tick-module-checkbox name)))) +(defun erc--fill-module-docstring (&rest strings) + (with-temp-buffer + (emacs-lisp-mode) + (insert "(defun foo ()\n" + (format "%S" (apply #'concat strings)) + "\n(ignore))") + (goto-char (point-min)) + (forward-line 2) + (let ((emacs-lisp-docstring-fill-column 65) + (sentence-end-double-space t)) + (fill-paragraph)) + (goto-char (point-min)) + (nth 3 (read (current-buffer))))) + (defmacro define-erc-module (name alias doc enable-body disable-body &optional local-p) "Define a new minor mode using ERC conventions. @@ -289,11 +303,11 @@ define-erc-module `(progn (define-minor-mode ,mode - ,(format "Toggle ERC %S mode. + ,(erc--fill-module-docstring (format "Toggle ERC %s mode. With a prefix argument ARG, enable %s if ARG is positive, and disable it otherwise. If called from Lisp, enable the mode if ARG is omitted or nil. -%s" name name doc) +\n%s" name name doc)) :global ,(not local-p) :group (erc--find-group ',name ,(and alias (list 'quote alias))) ,@(unless local-p '(:get #'erc--neuter-custom-variable-state)) diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index b1df04841a4..ae19b7d0aad 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -1472,7 +1472,7 @@ erc--merge-local-modes (ert-deftest define-erc-module--global () (let ((global-module '(define-erc-module mname malias - "Some docstring" + "Some docstring." ((ignore a) (ignore b)) ((ignore c) (ignore d))))) @@ -1484,10 +1484,11 @@ define-erc-module--global (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" +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--find-group 'mname 'malias) :get #'erc--neuter-custom-variable-state @@ -1528,7 +1529,7 @@ define-erc-module--global (ert-deftest define-erc-module--local () (let* ((global-module '(define-erc-module mname nil ; no alias - "Some docstring" + "Some docstring." ((ignore a) (ignore b)) ((ignore c) (ignore d)) 'local)) @@ -1540,10 +1541,11 @@ define-erc-module--local `(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" +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--find-group 'mname nil) (if erc-mname-mode @@ -1552,7 +1554,8 @@ define-erc-module--local (defun erc-mname-enable (&optional ,arg-en) "Enable ERC mname mode. -When called interactively, do so in all buffers for the current connection." +When called interactively, do so in all buffers for the current +connection." (interactive "p") (when (derived-mode-p 'erc-mode) (if ,arg-en @@ -1564,7 +1567,8 @@ define-erc-module--local (defun erc-mname-disable (&optional ,arg-dis) "Disable ERC mname mode. -When called interactively, do so in all buffers for the current connection." +When called interactively, do so in all buffers for the current +connection." (interactive "p") (when (derived-mode-p 'erc-mode) (if ,arg-dis commit 9c65ac73655c71a7f289d8c86ee6d7a314c32a05 Author: F. Jason Park Date: Sat Jan 14 19:08:11 2023 -0800 Warn when customizing minor-mode vars for ERC modules * lisp/erc/erc-common.el: (erc--inside-mode-toggle-p): Add global var to inhibit mode toggles from being run by `erc-update-modules'. It must be non-nil inside custom-set functions for mode toggles created by `define-erc-module'. (erc--favor-changed-reverted-modules-state): Add new helper to show a "SET" Custom state for `erc-modules' except when reverting to the default value because \"STANDARD\" always takes precedence, as explained somewhat in bug#12864. (erc--assemble-toggle): Don't modify `erc-modules' when run from custom-set function. (erc--neuter-custom-variable-state): Add new function to serve as a phony getter that deceives Customize into thinking the variable is always set to its standard value. The justification for this is that toggling a module's minor mode in Customize has never worked and has only sewn confusion in new users. Without this hack, mode widgets show a state of "CHANGED outside Customize", which alone is probably preferable, except that they all end up toggled open, bringing them unwanted attention and distracting the user. (erc--tick-module-checkbox): Add helper to toggle the appropriate checkbox in the `erc-modules' widget when a user interactively toggles a minor-mode state variable. (erc--prepare-custom-module-type): Create spec for minor-mode Custom `:type', deferring various aspects until module-definition time. (define-erc-module): Add `:get' and `:type' keywords to be passed to `defcustom' definition for global modules. * lisp/erc/erc.el (erc-modules): Inhibit `erc-update-modules' when run from a minor-mode toggle's custom-set function. * test/lisp/erc/erc-tests.el (define-erc-module--global, define-erc-module--local): Update `erc-modules' mutations with `erc--inside-mode-toggle-p' guard conditions. (Bug#60935.) diff --git a/lisp/erc/erc-common.el b/lisp/erc/erc-common.el index 91ddce8fbd9..c01c0323453 100644 --- a/lisp/erc/erc-common.el +++ b/lisp/erc/erc-common.el @@ -31,12 +31,18 @@ erc--casemapping-rfc1459-strict (defvar erc-channel-users) (defvar erc-dbuf) (defvar erc-log-p) +(defvar erc-modules) (defvar erc-server-users) (defvar erc-session-server) (declare-function erc--get-isupport-entry "erc-backend" (key &optional single)) (declare-function erc-get-buffer "erc" (target &optional proc)) (declare-function erc-server-buffer "erc" nil) +(declare-function widget-apply-action "wid-edit" (widget &optional event)) +(declare-function widget-at "wid-edit" (&optional pos)) +(declare-function widget-get-sibling "wid-edit" (widget)) +(declare-function widget-move "wid-edit" (arg &optional suppress-echo)) +(declare-function widget-type "wid-edit" (widget)) (cl-defstruct erc-input string insertp sendp) @@ -93,6 +99,40 @@ erc--normalize-module-symbol (setq symbol canonical)) symbol) +(defvar erc--inside-mode-toggle-p nil + "Non-nil when a module's mode toggle is updating module membership. +This serves as a flag to inhibit the mutual recursion that would +otherwise occur between an ERC-defined minor-mode function, such +as `erc-services-mode', and the custom-set function for +`erc-modules'. For historical reasons, the latter calls +`erc-update-modules', which, in turn, enables the minor-mode +functions for all member modules. Also non-nil when a mode's +widget runs its set function.") + +(defun erc--favor-changed-reverted-modules-state (name op) + "Be more nuanced in displaying Custom state of `erc-modules'. +When `customized-value' differs from `saved-value', allow widget +to behave normally and show \"SET for current session\", as +though `customize-set-variable' or similar had been applied. +However, when `customized-value' and `standard-value' match but +differ from `saved-value', prefer showing \"CHANGED outside +Customize\" to prevent the widget from seeing a `standard' +instead of a `set' state, which precludes any actual saving." + ;; Although the button "Apply and save" is fortunately grayed out, + ;; `Custom-save' doesn't actually save (users must click the magic + ;; state button instead). The default behavior described in the doc + ;; string is intentional and was introduced by bug#12864 "Make state + ;; button interaction less confusing". However, it is unfriendly to + ;; rogue libraries (like ours) that insist on mutating user options + ;; as a matter of course. + (custom-load-symbol 'erc-modules) + (funcall (get 'erc-modules 'custom-set) 'erc-modules + (funcall op (erc--normalize-module-symbol name) erc-modules)) + (when (equal (pcase (get 'erc-modules 'saved-value) + (`((quote ,saved) saved))) + erc-modules) + (customize-mark-as-set 'erc-modules))) + (defun erc--assemble-toggle (localp name ablsym mode val body) (let ((arg (make-symbol "arg"))) `(defun ,ablsym ,(if localp `(&optional ,arg) '()) @@ -110,11 +150,17 @@ erc--assemble-toggle (,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))) + ;; No need for `default-value', etc. because a buffer-local + ;; `erc-modules' only influences the next session and + ;; doesn't survive the major-mode reset that soon follows. + `((unless + (or erc--inside-mode-toggle-p + ,@(let ((v `(memq ',(erc--normalize-module-symbol name) + erc-modules))) + `(,(if val v `(not ,v))))) + (let ((erc--inside-mode-toggle-p t)) + (erc--favor-changed-reverted-modules-state + ',name #',(if val 'cons 'delq)))) (setq ,mode ,val) ,@body))))) @@ -149,6 +195,61 @@ erc--find-group (throw 'found found))) 'erc)) +(defun erc--neuter-custom-variable-state (variable) + "Lie to Customize about VARIABLE's true state. +Do so by always returning its standard value, namely nil." + ;; Make a module's global minor-mode toggle blind to Customize, so + ;; that `customize-variable-state' never sees it as "changed", + ;; regardless of its value. This snippet is + ;; `custom--standard-value' from Emacs 28+. + (cl-assert (null (eval (car (get variable 'standard-value)) t))) + nil) + +;; This exists as a separate, top-level function to prevent the byte +;; compiler from warning about widget-related dependencies not being +;; loaded at runtime. + +(defun erc--tick-module-checkbox (name &rest _) ; `name' must be normalized + (customize-variable-other-window 'erc-modules) + ;; Move to `erc-modules' section. + (while (not (eq (widget-type (widget-at)) 'checkbox)) + (widget-move 1 t)) + ;; This search for a checkbox can fail when `name' refers to a + ;; third-party module that modifies `erc-modules' (improperly) on + ;; load. + (let (w) + (while (and (eq (widget-type (widget-at)) 'checkbox) + (not (and (setq w (widget-get-sibling (widget-at))) + (eq (widget-value w) name)))) + (setq w nil) + (widget-move 1 t)) ; the `suppress-echo' arg exists in 27.2 + (unless w + (error "Failed to find %s in `erc-modules' checklist" name)) + (widget-apply-action (widget-at)) + (message "Hit %s to apply or %s to apply and save." + (substitute-command-keys "\\[Custom-set]") + (substitute-command-keys "\\[Custom-save]")))) + +(defun erc--prepare-custom-module-type (name) + `(let* ((name (erc--normalize-module-symbol ',name)) + (fmtd (format " `%s' " name))) + `(boolean + :button-face '(custom-variable-obsolete custom-button) + :format "%{%t%}: %[Deprecated Toggle%] \n%h\n" + :documentation-property + ,(lambda (_) + (let ((hasp (memq name erc-modules))) + (concat "Setting a module's minor-mode variable is " + (propertize "ineffective" 'face 'error) + ".\nPlease " (if hasp "remove" "add") fmtd + (if hasp "from" "to") " `erc-modules' directly instead.\n" + "You can do so now by clicking the scary button above."))) + :help-echo ,(lambda (_) + (let ((hasp (memq name erc-modules))) + (concat (if hasp "Remove" "Add") fmtd + (if hasp "from" "to") " `erc-modules'."))) + :action ,(apply-partially #'erc--tick-module-checkbox name)))) + (defmacro define-erc-module (name alias doc enable-body disable-body &optional local-p) "Define a new minor mode using ERC conventions. @@ -195,6 +296,8 @@ define-erc-module %s" name name doc) :global ,(not local-p) :group (erc--find-group ',name ,(and alias (list 'quote alias))) + ,@(unless local-p '(:get #'erc--neuter-custom-variable-state)) + ,@(unless local-p `(:type ,(erc--prepare-custom-module-type name))) (if ,mode (,enable) (,disable))) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index cc5cac87da8..ea581c17661 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -1898,7 +1898,8 @@ erc-modules (nreverse third-party)))) ;; this test is for the case where erc hasn't been loaded yet (when (fboundp 'erc-update-modules) - (erc-update-modules))) + (unless erc--inside-mode-toggle-p + (erc-update-modules)))) :type '(set :greedy t diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index 45d8cae5125..b1df04841a4 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -1476,7 +1476,10 @@ define-erc-module--global ((ignore a) (ignore b)) ((ignore c) (ignore d))))) - (should (equal (macroexpand global-module) + (should (equal (cl-letf (((symbol-function + 'erc--prepare-custom-module-type) + #'symbol-name)) + (macroexpand global-module)) `(progn (define-minor-mode erc-mname-mode @@ -1487,6 +1490,8 @@ define-erc-module--global Some docstring" :global t :group (erc--find-group 'mname 'malias) + :get #'erc--neuter-custom-variable-state + :type "mname" (if erc-mname-mode (erc-mname-enable) (erc-mname-disable))) @@ -1494,14 +1499,22 @@ define-erc-module--global (defun erc-mname-enable () "Enable ERC mname mode." (interactive) - (cl-pushnew 'mname erc-modules) + (unless (or erc--inside-mode-toggle-p + (memq 'mname erc-modules)) + (let ((erc--inside-mode-toggle-p t)) + (erc--favor-changed-reverted-modules-state + 'mname #'cons))) (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)) + (unless (or erc--inside-mode-toggle-p + (not (memq 'mname erc-modules))) + (let ((erc--inside-mode-toggle-p t)) + (erc--favor-changed-reverted-modules-state + 'mname #'delq))) (setq erc-mname-mode nil) (ignore c) (ignore d)) commit 0d3ccdbde441a0eed5d80d64aea429bc9a6457a3 Author: F. Jason Park Date: Sat Jan 14 19:05:59 2023 -0800 Don't associate ERC modules with undefined groups * lisp/erc/erc-capab.el: Add property crutch to help ERC find module's Custom group. * lisp/erc/erc-common.el (erc--find-group): Add new function, a helper for finding an existing ERC module's Custom group based on `define-erc-module' params. Prefer `group-documentation' as a sentinel over symbol properties owned by Customize because they might not be present if the group isn't yet associated with any custom variables. (define-erc-module): Set `:group' keyword value more accurately, falling back to `erc' when no associated group has been defined. * test/lisp/erc/erc-tests.el (erc--find-group, erc--find-group--real): New tests. (define-erc-module--global, define-erc-module--local): Expect the `:group' keyword to be the unevaluated `erc--find-group' form. (Bug#60935.) diff --git a/lisp/erc/erc-capab.el b/lisp/erc/erc-capab.el index 650c5fa84ac..bb0921da7f0 100644 --- a/lisp/erc/erc-capab.el +++ b/lisp/erc/erc-capab.el @@ -89,6 +89,7 @@ erc-capab-identify-unidentified ;;; Define module: ;;;###autoload(autoload 'erc-capab-identify-mode "erc-capab" nil t) +(put 'capab-identify 'erc-group 'erc-capab) (define-erc-module capab-identify nil "Handle dancer-ircd's CAPAB IDENTIFY-MSG and IDENTIFY-CTCP." ;; append so that `erc-server-parameters' is already set by `erc-server-005' diff --git a/lisp/erc/erc-common.el b/lisp/erc/erc-common.el index b8f6a06b76c..91ddce8fbd9 100644 --- a/lisp/erc/erc-common.el +++ b/lisp/erc/erc-common.el @@ -118,6 +118,37 @@ erc--assemble-toggle (setq ,mode ,val) ,@body))))) +;; This is a migration helper that determines a module's `:group' +;; keyword argument from its name or alias. A (global) module's minor +;; mode variable appears under the group's Custom menu. Like +;; `erc--normalize-module-symbol', it must run when the module's +;; definition (rather than that of `define-erc-module') is expanded. +;; For corner cases in which this fails or the catch-all of `erc' is +;; more inappropriate, (global) modules can declare a top-level +;; +;; (put 'foo 'erc-group 'erc-bar) +;; +;; where `erc-bar' is the group and `foo' is the normalized module. +;; Do this *before* the module's definition. If `define-erc-module' +;; ever accepts arbitrary keywords, passing an explicit `:group' will +;; obviously be preferable. + +(defun erc--find-group (&rest symbols) + (catch 'found + (dolist (s symbols) + (let* ((downed (downcase (symbol-name s))) + (known (intern-soft (concat "erc-" downed)))) + (when (and known + (or (get known 'group-documentation) + (rassq known custom-current-group-alist))) + (throw 'found known)) + (when (setq known (intern-soft (concat "erc-" downed "-mode"))) + (when-let ((found (custom-group-of-mode known))) + (throw 'found found)))) + (when-let ((found (get (erc--normalize-module-symbol s) 'erc-group))) + (throw 'found found))) + 'erc)) + (defmacro define-erc-module (name alias doc enable-body disable-body &optional local-p) "Define a new minor mode using ERC conventions. @@ -152,7 +183,6 @@ define-erc-module (declare (doc-string 3) (indent defun)) (let* ((sn (symbol-name name)) (mode (intern (format "erc-%s-mode" (downcase sn)))) - (group (intern (format "erc-%s" (downcase sn)))) (enable (intern (format "erc-%s-enable" (downcase sn)))) (disable (intern (format "erc-%s-disable" (downcase sn))))) `(progn @@ -163,10 +193,8 @@ define-erc-module and disable it otherwise. If called from Lisp, enable the mode if ARG is omitted or nil. %s" name name doc) - ;; FIXME: We don't know if this group exists, so this `:group' may - ;; actually just silence a valid warning about the fact that the var - ;; is not associated with any group. - :global ,(not local-p) :group (quote ,group) + :global ,(not local-p) + :group (erc--find-group ',name ,(and alias (list 'quote alias))) (if ,mode (,enable) (,disable))) diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index acd470a1e17..45d8cae5125 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -1353,6 +1353,39 @@ erc-migrate-modules ;; Default unchanged (should (equal (erc-migrate-modules erc-modules) erc-modules))) +(ert-deftest erc--find-group () + ;; These two are loaded by default + (should (eq (erc--find-group 'keep-place nil) 'erc)) + (should (eq (erc--find-group 'networks nil) 'erc-networks)) + ;; These are fake + (cl-letf (((get 'erc-bar 'group-documentation) "") + ((get 'baz 'erc-group) 'erc-foo)) + (should (eq (erc--find-group 'foo 'bar) 'erc-bar)) + (should (eq (erc--find-group 'bar 'foo) 'erc-bar)) + (should (eq (erc--find-group 'bar nil) 'erc-bar)) + (should (eq (erc--find-group 'foo nil) 'erc)) + (should (eq (erc--find-group 'fake 'baz) 'erc-foo)))) + +(ert-deftest erc--find-group--real () + :tags '(:unstable) + (require 'erc-services) + (require 'erc-stamp) + (require 'erc-sound) + (require 'erc-page) + (require 'erc-join) + (require 'erc-capab) + (require 'erc-pcomplete) + (should (eq (erc--find-group 'services 'nickserv) 'erc-services)) + (should (eq (erc--find-group 'stamp 'timestamp) 'erc-stamp)) + (should (eq (erc--find-group 'sound 'ctcp-sound) 'erc-sound)) + (should (eq (erc--find-group 'page 'ctcp-page) 'erc-page)) + (should (eq (erc--find-group 'autojoin) 'erc-autojoin)) + (should (eq (erc--find-group 'pcomplete 'Completion) 'erc-pcomplete)) + (should (eq (erc--find-group 'capab-identify) 'erc-capab)) + ;; No group specified. + (should (eq (erc--find-group 'smiley nil) 'erc)) + (should (eq (erc--find-group 'unmorse nil) 'erc))) + (ert-deftest erc--update-modules () (let (calls erc-modules @@ -1453,7 +1486,7 @@ define-erc-module--global if ARG is omitted or nil. Some docstring" :global t - :group 'erc-mname + :group (erc--find-group 'mname 'malias) (if erc-mname-mode (erc-mname-enable) (erc-mname-disable))) @@ -1499,7 +1532,7 @@ define-erc-module--local if ARG is omitted or nil. Some docstring" :global nil - :group 'erc-mname + :group (erc--find-group 'mname nil) (if erc-mname-mode (erc-mname-enable) (erc-mname-disable))) commit 2d876a4ca94d7c74339eb18ca98528d017cab2a8 Author: F. Jason Park Date: Thu Jan 19 21:07:27 2023 -0800 Convert ERC's Imenu integration into proper module * lisp/erc/erc-goodies.el: Don't add Imenu hooks to `erc-mode-hook' at top level. Remove autoload for `erc-create-imenu-index' because it already exists in the `erc-imenu' library. (erc-imenu-setup): Move to the erc-imenu library. * lisp/erc/erc-imenu.el (erc-unfill-notice): Allow modifications to read-only text. Thanks to Yusef Aslam for reporting this bug. (erc-imenu-setup): Move here from goodies. (erc-imenu--create-index-function): New helper var to hold previous local value of `imenu-create-index-function'. Perhaps advice should be used instead, but a cursory search of the Emacs code base reveals no such usage. (erc-imenu-mode, erc-imenu-enable, erc-imenu-disable): Create "new" ERC module for Imenu integration. * lisp/erc/erc.el (erc-modules): Add `imenu' to default value and create widget menu item. Update package-version. * test/lisp/erc/erc-tests.el (erc-tests--modules): Add `imenu'. (Bug#60954) diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el index 5ddacb643fd..7ea6c42ec65 100644 --- a/lisp/erc/erc-goodies.el +++ b/lisp/erc/erc-goodies.el @@ -32,12 +32,6 @@ (eval-when-compile (require 'cl-lib)) (require 'erc) -(defun erc-imenu-setup () - "Setup Imenu support in an ERC buffer." - (setq-local imenu-create-index-function #'erc-create-imenu-index)) - -(add-hook 'erc-mode-hook #'erc-imenu-setup) -(autoload 'erc-create-imenu-index "erc-imenu" "Imenu index creation function") ;;; Automatically scroll to bottom (defcustom erc-input-line-position nil diff --git a/lisp/erc/erc-imenu.el b/lisp/erc/erc-imenu.el index 6223cd3d06f..526afd32249 100644 --- a/lisp/erc/erc-imenu.el +++ b/lisp/erc/erc-imenu.el @@ -52,7 +52,8 @@ erc-unfill-notice (forward-line 1) (looking-at " ")) (forward-line 1)) - (end-of-line) (point))))) + (end-of-line) (point)))) + (inhibit-read-only t)) (with-temp-buffer (insert str) (goto-char (point-min)) @@ -124,6 +125,26 @@ erc-create-imenu-index index-alist)) index-alist)) +(defvar-local erc-imenu--create-index-function nil + "Previous local value of `imenu-create-index-function', if any.") + +(defun erc-imenu-setup () + "Wire up support for Imenu in an ERC buffer." + (when (and (local-variable-p 'imenu-create-index-function) + imenu-create-index-function) + (setq erc-imenu--create-index-function imenu-create-index-function)) + (setq imenu-create-index-function #'erc-create-imenu-index)) + +;;;###autoload(autoload 'erc-imenu-mode "erc-imenu" nil t) +(define-erc-module imenu nil + "Simple Imenu integration for ERC." + ((add-hook 'erc-mode-hook #'erc-imenu-setup)) + ((remove-hook 'erc-mode-hook #'erc-imenu-setup) + (erc-with-all-buffers-of-server erc-server-process nil + (when erc-imenu--create-index-function + (setq imenu-create-index-function erc-imenu--create-index-function) + (kill-local-variable 'erc-imenu--create-index-function))))) + (provide 'erc-imenu) ;;; erc-imenu.el ends here diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 60fe0480412..cc5cac87da8 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -1852,7 +1852,7 @@ erc-migrate-modules ;; each item is in the format '(old . new) (delete-dups (mapcar #'erc--normalize-module-symbol mods))) -(defcustom erc-modules '( autojoin button completion fill irccontrols +(defcustom erc-modules '( autojoin button completion fill imenu irccontrols list match menu move-to-prompt netsplit networks noncommands readonly ring stamp track) "A list of modules which ERC should enable. @@ -1912,6 +1912,7 @@ erc-modules (const :tag "dcc: Provide Direct Client-to-Client support" dcc) (const :tag "fill: Wrap long lines" fill) (const :tag "identd: Launch an identd server on port 8113" identd) + (const :tag "imenu: A simple Imenu integration" imenu) (const :tag "irccontrols: Highlight or remove IRC control characters" irccontrols) (const :tag "keep-place: Leave point above un-viewed text" keep-place) @@ -1949,6 +1950,7 @@ erc-modules (const :tag "unmorse: Translate morse code in messages" unmorse) (const :tag "xdcc: Act as an XDCC file-server" xdcc) (repeat :tag "Others" :inline t symbol)) + :package-version '(ERC . "5.6") ; FIXME sync on release :group 'erc) (defun erc-update-modules () diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index 0c7b06da436..acd470a1e17 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -1270,7 +1270,7 @@ erc-handle-irc-url (defconst erc-tests--modules '( autoaway autojoin button capab-identify completion dcc fill identd - irccontrols keep-place list log match menu move-to-prompt netsplit + imenu irccontrols keep-place list log match menu move-to-prompt netsplit networks noncommands notifications notify page readonly replace ring sasl scrolltobottom services smiley sound spelling stamp track truncate unmorse xdcc)) commit 22104de5daa12e82bb6a246f05f4cd2927eb37a3 Author: F. Jason Park Date: Fri Jul 9 20:03:51 2021 -0700 Add missing colors to erc-irccontrols-mode * lisp/erc/erc-goodies.el (erc-spoiler-face): Add new face. (erc--controls-additional-colors): Add remaining 16-99 colors. (erc-get-bg-color-face, erc-get-fg-color-face): Look up extended colors in table. (erc-controls-remove-regexp, erc-controls-highlight-regexp): Convert to `rx' forms and move above first use to eliminate intra-file forward declarations. (erc-controls-propertize): Support spoilers. * test/lisp/erc/erc-goodies-tests.el: New file. (Bug#60954.) diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el index 7ff5b1aecdf..5ddacb643fd 100644 --- a/lisp/erc/erc-goodies.el +++ b/lisp/erc/erc-goodies.el @@ -30,8 +30,6 @@ ;;; Code: (eval-when-compile (require 'cl-lib)) -(defvar erc-controls-highlight-regexp) -(defvar erc-controls-remove-regexp) (require 'erc) (defun erc-imenu-setup () @@ -243,6 +241,12 @@ erc-inverse-face "ERC inverse face." :group 'erc-faces) +(defface erc-spoiler-face + '((((background light)) :foreground "DimGray" :background "DimGray") + (((background dark)) :foreground "LightGray" :background "LightGray")) + "ERC spoiler face." + :group 'erc-faces) + (defface erc-underline-face '((t :underline t)) "ERC underline face." :group 'erc-faces) @@ -345,19 +349,38 @@ bg:erc-color-face15 "ERC face." :group 'erc-faces) +;; https://lists.gnu.org/archive/html/emacs-erc/2021-07/msg00005.html +(defvar erc--controls-additional-colors + ["#470000" "#472100" "#474700" "#324700" "#004700" "#00472c" + "#004747" "#002747" "#000047" "#2e0047" "#470047" "#47002a" + "#740000" "#743a00" "#747400" "#517400" "#007400" "#007449" + "#007474" "#004074" "#000074" "#4b0074" "#740074" "#740045" + "#b50000" "#b56300" "#b5b500" "#7db500" "#00b500" "#00b571" + "#00b5b5" "#0063b5" "#0000b5" "#7500b5" "#b500b5" "#b5006b" + "#ff0000" "#ff8c00" "#ffff00" "#b2ff00" "#00ff00" "#00ffa0" + "#00ffff" "#008cff" "#0000ff" "#a500ff" "#ff00ff" "#ff0098" + "#ff5959" "#ffb459" "#ffff71" "#cfff60" "#6fff6f" "#65ffc9" + "#6dffff" "#59b4ff" "#5959ff" "#c459ff" "#ff66ff" "#ff59bc" + "#ff9c9c" "#ffd39c" "#ffff9c" "#e2ff9c" "#9cff9c" "#9cffdb" + "#9cffff" "#9cd3ff" "#9c9cff" "#dc9cff" "#ff9cff" "#ff94d3" + "#000000" "#131313" "#282828" "#363636" "#4d4d4d" "#656565" + "#818181" "#9f9f9f" "#bcbcbc" "#e2e2e2" "#ffffff"]) + (defun erc-get-bg-color-face (n) "Fetches the right face for background color N (0-15)." (if (stringp n) (setq n (string-to-number n))) (if (not (numberp n)) (prog1 'default (erc-error "erc-get-bg-color-face: n is NaN: %S" n)) - (when (> n 16) + (when (> n 99) (erc-log (format " Wrong color: %s" n)) (setq n (mod n 16))) (cond ((and (>= n 0) (< n 16)) (intern (concat "bg:erc-color-face" (number-to-string n)))) - (t (erc-log (format " Wrong color: %s" n)) 'default)))) + ((< 15 n 99) + (list :background (aref erc--controls-additional-colors (- n 16)))) + (t (erc-log (format " Wrong color: %s" n)) '(default))))) (defun erc-get-fg-color-face (n) "Fetches the right face for foreground color N (0-15)." @@ -365,13 +388,15 @@ erc-get-fg-color-face (if (not (numberp n)) (prog1 'default (erc-error "erc-get-fg-color-face: n is NaN: %S" n)) - (when (> n 16) + (when (> n 99) (erc-log (format " Wrong color: %s" n)) (setq n (mod n 16))) (cond ((and (>= n 0) (< n 16)) (intern (concat "fg:erc-color-face" (number-to-string n)))) - (t (erc-log (format " Wrong color: %s" n)) 'default)))) + ((< 15 n 99) + (list :foreground (aref erc--controls-additional-colors (- n 16)))) + (t (erc-log (format " Wrong color: %s" n)) '(default))))) ;;;###autoload(autoload 'erc-irccontrols-mode "erc-goodies" nil t) (define-erc-module irccontrols nil @@ -383,6 +408,25 @@ irccontrols (remove-hook 'erc-send-modify-hook #'erc-controls-highlight) (erc--modify-local-map nil "C-c C-c" #'erc-toggle-interpret-controls))) +;; These patterns were moved here to circumvent compiler warnings but +;; otherwise translated verbatim from their original string-literal +;; definitions (minus a small bug fix to satisfy newly added tests). +(defvar erc-controls-remove-regexp + (rx (or ?\C-b ?\C-\] ?\C-_ ?\C-v ?\C-g ?\C-o + (: ?\C-c (? (any "0-9")) (? (any "0-9")) + (? (group ?, (any "0-9") (? (any "0-9"))))))) + "Regular expression matching control characters to remove.") + +;; Before the change to `rx', group 3 used to be a sibling of group 2. +;; This was assumed to be a bug. A few minor simplifications were +;; also performed. If incorrect, please admonish. +(defvar erc-controls-highlight-regexp + (rx (group (or ?\C-b ?\C-\] ?\C-v ?\C-_ ?\C-g ?\C-o + (: ?\C-c (? (group (** 1 2 (any "0-9"))) + (? (group ?, (group (** 1 2 (any "0-9"))))))))) + (group (* (not (any ?\C-b ?\C-c ?\C-g ?\n ?\C-o ?\C-v ?\C-\] ?\C-_))))) + "Regular expression matching control chars to highlight.") + (defun erc-controls-interpret (str) "Return a copy of STR after dealing with IRC control characters. See `erc-interpret-controls-p' and `erc-interpret-mirc-color' for options." @@ -444,16 +488,6 @@ erc-controls-strip (setq s (replace-match "" nil nil s))) s))) -(defvar erc-controls-remove-regexp - "\C-b\\|\C-]\\|\C-_\\|\C-v\\|\C-g\\|\C-o\\|\C-c[0-9]?[0-9]?\\(,[0-9][0-9]?\\)?" - "Regular expression which matches control characters to remove.") - -(defvar erc-controls-highlight-regexp - (concat "\\(\C-b\\|\C-]\\|\C-v\\|\C-_\\|\C-g\\|\C-o\\|" - "\C-c\\([0-9][0-9]?\\)?\\(,\\([0-9][0-9]?\\)\\)?\\)" - "\\([^\C-b\C-]\C-v\C-_\C-c\C-g\C-o\n]*\\)") - "Regular expression which matches control chars and the text to highlight.") - (defun erc-controls-highlight () "Highlight IRC control chars in the buffer. This is useful for `erc-insert-modify-hook' and `erc-send-modify-hook'. @@ -510,6 +544,13 @@ erc-controls-propertize "Prepend properties from IRC control characters between FROM and TO. If optional argument STR is provided, apply to STR, otherwise prepend properties to a region in the current buffer." + (if (and fg bg (equal fg bg)) + (progn + (setq fg 'erc-spoiler-face + bg nil) + (put-text-property from to 'mouse-face 'erc-inverse-face str)) + (when fg (setq fg (erc-get-fg-color-face fg))) + (when bg (setq bg (erc-get-bg-color-face bg)))) (font-lock-prepend-text-property from to @@ -527,10 +568,10 @@ erc-controls-propertize '(erc-underline-face) nil) (if fg - (list (erc-get-fg-color-face fg)) + (list fg) nil) (if bg - (list (erc-get-bg-color-face bg)) + (list bg) nil)) str) str) diff --git a/test/lisp/erc/erc-goodies-tests.el b/test/lisp/erc/erc-goodies-tests.el new file mode 100644 index 00000000000..46fcf82401b --- /dev/null +++ b/test/lisp/erc/erc-goodies-tests.el @@ -0,0 +1,253 @@ +;;; erc-goodies-tests.el --- Tests for erc-goodies -*- lexical-binding:t -*- + +;; Copyright (C) 2023 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-goodies) +(declare-function erc--initialize-markers "erc" (old-point continued) t) + +(defun erc-goodies-tests--assert-face (beg end-str present &optional absent) + (setq beg (+ beg (point-min))) + (let ((end (+ beg (1- (length end-str))))) + (while (and beg (< beg end)) + (let* ((val (get-text-property beg 'font-lock-face)) + (ft (flatten-tree (ensure-list val)))) + (dolist (p (ensure-list present)) + (if (consp p) + (should (member p val)) + (should (memq p ft)))) + (dolist (a (ensure-list absent)) + (if (consp a) + (should-not (member a val)) + (should-not (memq a ft)))) + (setq beg (text-property-not-all beg (point-max) + 'font-lock-face val)))))) + +;; These are from the "Examples" section of +;; https://modern.ircdocs.horse/formatting.html + +(ert-deftest erc-controls-highlight--examples () + ;; FIXME remove after adding + (unless (fboundp 'erc--initialize-markers) + (ert-skip "Missing required function")) + (should (eq t erc-interpret-controls-p)) + (let ((erc-insert-modify-hook '(erc-controls-highlight)) + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + (with-current-buffer (get-buffer-create "#chan") + (erc-mode) + (setq-local erc-interpret-mirc-color t) + (erc--initialize-markers (point) nil) + + (let* ((m "I love \C-c3IRC!\C-c It is the \C-c7best protocol ever!") + (msg (erc-format-privmessage "bob" m nil t))) + (erc-display-message nil nil (current-buffer) msg)) + (forward-line -1) + (should (search-forward " " nil t)) + (save-restriction + (narrow-to-region (point) (pos-eol)) + (erc-goodies-tests--assert-face + 0 "I love" 'erc-default-face 'fg:erc-color-face3) + (erc-goodies-tests--assert-face + 7 " IRC!" 'fg:erc-color-face3) + (erc-goodies-tests--assert-face + 11 " It is the " 'erc-default-face 'fg:erc-color-face7) + (erc-goodies-tests--assert-face + 22 "best protocol ever!" 'fg:erc-color-face7)) + + (let* ((m "This is a \C-]\C-c13,9cool \C-cmessage") + (msg (erc-format-privmessage "alice" m nil t))) + (erc-display-message nil nil (current-buffer) msg)) + (should (search-forward " " nil t)) + (save-restriction + (narrow-to-region (point) (pos-eol)) + (erc-goodies-tests--assert-face + 0 "this is a " 'erc-default-face 'erc-italic-face) + (erc-goodies-tests--assert-face + 10 "cool " '(erc-italic-face fg:erc-color-face13 bg:erc-color-face9)) + (erc-goodies-tests--assert-face + 15 "message" 'erc-italic-face + '(fg:erc-color-face13 bg:erc-color-face9))) + + (let* ((m "IRC \C-bis \C-c4,12so \C-cgreat\C-o!") + (msg (erc-format-privmessage "bob" m nil t))) + (erc-display-message nil nil (current-buffer) msg)) + (should (search-forward " " nil t)) + (save-restriction + (narrow-to-region (point) (pos-eol)) + (erc-goodies-tests--assert-face + 0 "IRC " 'erc-default-face 'erc-bold-face) + (erc-goodies-tests--assert-face + 4 "is " 'erc-bold-face '(fg:erc-color-face4 bg:erc-color-face12)) + (erc-goodies-tests--assert-face + 7 "so " '(erc-bold-face fg:erc-color-face4 bg:erc-color-face12)) + (erc-goodies-tests--assert-face + 10 "great" 'erc-bold-face '(fg:erc-color-face4 bg:erc-color-face12)) + (erc-goodies-tests--assert-face + 15 "!" 'erc-default-face 'erc-bold-face)) + + (let* ((m (concat "Rules: Don't spam 5\C-c13,8,6\C-c,7,8, " + "and especially not \C-b9\C-b\C-]!")) + (msg (erc-format-privmessage "alice" m nil t))) + (erc-display-message nil nil (current-buffer) msg)) + (should (search-forward " " nil t)) + (save-restriction + (narrow-to-region (point) (pos-eol)) + (erc-goodies-tests--assert-face + 0 "Rules: Don't spam 5" 'erc-default-face + '(fg:erc-color-face13 bg:erc-color-face8)) + (erc-goodies-tests--assert-face + 19 ",6" '(fg:erc-color-face13 bg:erc-color-face8)) + (erc-goodies-tests--assert-face + 21 ",7,8, and especially not " 'erc-default-face + '(fg:erc-color-face13 bg:erc-color-face8 erc-bold-face)) + (erc-goodies-tests--assert-face + 44 "9" 'erc-bold-face 'erc-italic-face) + (erc-goodies-tests--assert-face + 45 "!" 'erc-italic-face 'erc-bold-face)) + + (when noninteractive + (kill-buffer))))) + +;; Like the test above, this is most intuitive when run interactively. +;; Hovering over the redacted area should reveal its underlying text +;; in a high-contrast face. + +(ert-deftest erc-controls-highlight--inverse () + ;; FIXME remove after adding + (unless (fboundp 'erc--initialize-markers) + (ert-skip "Missing required function")) + (should (eq t erc-interpret-controls-p)) + (let ((erc-insert-modify-hook '(erc-controls-highlight)) + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + (with-current-buffer (get-buffer-create "#chan") + (erc-mode) + (setq-local erc-interpret-mirc-color t) + (erc--initialize-markers (point) nil) + + (let* ((m "Spoiler: \C-c0,0Hello\C-c1,1World!") + (msg (erc-format-privmessage "bob" m nil t))) + (erc-display-message nil nil (current-buffer) msg)) + (forward-line -1) + (should (search-forward " " nil t)) + (save-restriction + (narrow-to-region (point) (pos-eol)) + (should (eq (get-text-property (+ 9 (point)) 'mouse-face) + 'erc-inverse-face)) + (should (eq (get-text-property (1- (pos-eol)) 'mouse-face) + 'erc-inverse-face)) + (erc-goodies-tests--assert-face + 0 "Spoiler: " 'erc-default-face + '(fg:erc-color-face0 bg:erc-color-face0)) + (erc-goodies-tests--assert-face + 9 "Hello" '(erc-spoiler-face) + '( fg:erc-color-face0 bg:erc-color-face0 + fg:erc-color-face1 bg:erc-color-face1)) + (erc-goodies-tests--assert-face + 18 " World" '(erc-spoiler-face) + '( fg:erc-color-face0 bg:erc-color-face0 + fg:erc-color-face1 bg:erc-color-face1 ))) + (when noninteractive + (kill-buffer))))) + +(defvar erc-goodies-tests--motd + ;; This is from ergo's MOTD + '((":- - this is \2bold text\17.") + (":- - this is \35italics text\17.") + (":- - this is \0034red\3 and \0032blue\3 text.") + (":- - this is \0034,12red text with a light blue background\3.") + (":- - this is a normal escaped dollarsign: $") + (":- ") + (":- " + "\0031,0 00 \0030,1 01 \0030,2 02 \0030,3 03 " + "\0031,4 04 \0030,5 05 \0030,6 06 \0031,7 07 ") + (":- " + "\0031,8 08 \0031,9 09 \0030,10 10 \0031,11 11 " + "\0030,12 12 \0031,13 13 \0031,14 14 \0031,15 15 ") + (":- ") + (":- " + "\0030,16 16 \0030,17 17 \0030,18 18 \0030,19 19 " + "\0030,20 20 \0030,21 21 \0030,22 22 \0030,23 23 " + "\0030,24 24 \0030,25 25 \0030,26 26 \0030,27 27 ") + (":- " + "\0030,28 28 \0030,29 29 \0030,30 30 \0030,31 31 " + "\0030,32 32 \0030,33 33 \0030,34 34 \0030,35 35 " + "\0030,36 36 \0030,37 37 \0030,38 38 \0030,39 39 ") + (":- " + "\0030,40 40 \0030,41 41 \0030,42 42 \0030,43 43 " + "\0030,44 44 \0030,45 45 \0030,46 46 \0030,47 47 " + "\0030,48 48 \0030,49 49 \0030,50 50 \0030,51 51 ") + (":- " + "\0030,52 52 \0030,53 53 \0031,54 54 \0031,55 55 " + "\0031,56 56 \0031,57 57 \0031,58 58 \0030,59 59 " + "\0030,60 60 \0030,61 61 \0030,62 62 \0030,63 63 ") + (":- " + "\0030,64 64 \0031,65 65 \0031,66 66 \0031,67 67 " + "\0031,68 68 \0031,69 69 \0031,70 70 \0031,71 71 " + "\0030,72 72 \0030,73 73 \0030,74 74 \0030,75 75 ") + (":- " + "\0031,76 76 \0031,77 77 \0031,78 78 \0031,79 79 " + "\0031,80 80 \0031,81 81 \0031,82 82 \0031,83 83 " + "\0031,84 84 \0031,85 85 \0031,86 86 \0031,87 87 ") + (":- " + "\0030,88 88 \0030,89 89 \0030,90 90 \0030,91 91 " + "\0030,92 92 \0030,93 93 \0030,94 94 \0030,95 95 " + "\0031,96 96 \0031,97 97 \0031,98 98 \399,99 99 ") + (":- "))) + +(ert-deftest erc-controls-highlight--motd () + ;; FIXME remove after adding + (unless (fboundp 'erc--initialize-markers) + (ert-skip "Missing required function")) + (should (eq t erc-interpret-controls-p)) + (let ((erc-insert-modify-hook '(erc-controls-highlight)) + erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + (with-current-buffer (get-buffer-create "#chan") + (erc-mode) + (setq-local erc-interpret-mirc-color t) + (erc--initialize-markers (point) nil) + + (dolist (parts erc-goodies-tests--motd) + (erc-display-message nil 'notice (current-buffer) (string-join parts))) + + ;; Spot check + (goto-char (point-min)) + (should (search-forward " 16 " nil t)) + (save-restriction + (narrow-to-region (point) (pos-eol)) + (erc-goodies-tests--assert-face + 0 " 17 " '(fg:erc-color-face0 (:background "#472100"))) + (erc-goodies-tests--assert-face + 4 " 18 " '(fg:erc-color-face0 (:background "#474700")) + '((:background "#472100")))) + + (should (search-forward " 71 " nil t)) + (save-restriction + (narrow-to-region (point) (pos-eol)) + (erc-goodies-tests--assert-face + 0 " 72 " '(fg:erc-color-face0 (:background "#5959ff"))) + (erc-goodies-tests--assert-face + 4 " 73 " '(fg:erc-color-face0 (:background "#c459ff")) + '((:background "#5959ff")))) + + (goto-char (point-min)) + (when noninteractive + (kill-buffer))))) + +;;; erc-goodies-tests.el ends here commit 9aa2806fdc3a440a9f108779f2f4a6972c203aff Author: F. Jason Park Date: Thu Jan 19 21:07:27 2023 -0800 Modify erc-mode-map in module definitions * lisp/erc/erc-button.el (erc-button-mode, erc-button-enable, erc-button-disable): Replace call to `erc-button-setup' with one to `erc--modify-local-map'. This means `erc-button-setup' is now dead code from a client perspective. * lisp/erc/erc-goodies.el (erc-irccontrols-enable, erc-irccontrols-disable, erc-irccontrols-mode): Bind `erc-toggle-interpret-controls' in module definition so it's only available when the module is active. * lisp/erc/erc-log.el (erc-log-mode, erc-log-enable, erc-log-disable): Move top-level `define-key' into module definition. * lisp/erc/erc-match.el (erc-match-mode, erc-match-enable, erc-match-disable): Move top-level `define-key' into module definition. * lisp/erc/erc.el (erc-mode-map): Remove C-c C-c binding for `erc-toggle-interpret-controls'. (erc--modify-local-map): Add helper for global modules to use when modifying `erc-mode-map'. * test/lisp/erc/erc-tests.el (erc--modify-local-map): Add test. Ensure modifications to `erc-mode-map' on loading `erc' and via `erc-mode-hook' still work. (Bug#60954.) diff --git a/lisp/erc/erc-button.el b/lisp/erc/erc-button.el index c28dddefa0e..1be56f5dc21 100644 --- a/lisp/erc/erc-button.el +++ b/lisp/erc/erc-button.el @@ -55,11 +55,11 @@ button ((add-hook 'erc-insert-modify-hook #'erc-button-add-buttons 'append) (add-hook 'erc-send-modify-hook #'erc-button-add-buttons 'append) (add-hook 'erc-complete-functions #'erc-button-next-function) - (add-hook 'erc-mode-hook #'erc-button-setup)) + (erc--modify-local-map t "" #'erc-button-previous)) ((remove-hook 'erc-insert-modify-hook #'erc-button-add-buttons) (remove-hook 'erc-send-modify-hook #'erc-button-add-buttons) (remove-hook 'erc-complete-functions #'erc-button-next-function) - (remove-hook 'erc-mode-hook #'erc-button-setup))) + (erc--modify-local-map nil "" #'erc-button-previous))) ;;; Variables @@ -233,6 +233,8 @@ erc-button-keys-added "Internal variable used to keep track of whether we've added the global-level ERC button keys yet.") +;; Maybe deprecate this function and `erc-button-keys-added' if they +;; continue to go unused for a another version (currently 5.6). (defun erc-button-setup () "Add ERC mode-level button movement keys. This is only done once." ;; Add keys. diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el index 7ca155ef9d0..7ff5b1aecdf 100644 --- a/lisp/erc/erc-goodies.el +++ b/lisp/erc/erc-goodies.el @@ -377,9 +377,11 @@ erc-get-fg-color-face (define-erc-module irccontrols nil "This mode enables the interpretation of IRC control chars." ((add-hook 'erc-insert-modify-hook #'erc-controls-highlight) - (add-hook 'erc-send-modify-hook #'erc-controls-highlight)) + (add-hook 'erc-send-modify-hook #'erc-controls-highlight) + (erc--modify-local-map t "C-c C-c" #'erc-toggle-interpret-controls)) ((remove-hook 'erc-insert-modify-hook #'erc-controls-highlight) - (remove-hook 'erc-send-modify-hook #'erc-controls-highlight))) + (remove-hook 'erc-send-modify-hook #'erc-controls-highlight) + (erc--modify-local-map nil "C-c C-c" #'erc-toggle-interpret-controls))) (defun erc-controls-interpret (str) "Return a copy of STR after dealing with IRC control characters. diff --git a/lisp/erc/erc-log.el b/lisp/erc/erc-log.el index 2cb9031640d..a44437ddcf7 100644 --- a/lisp/erc/erc-log.el +++ b/lisp/erc/erc-log.el @@ -230,7 +230,8 @@ log ;; append, so that 'erc-initialize-log-marker runs first (add-hook 'erc-connect-pre-hook #'erc-log-setup-logging 'append) (dolist (buffer (erc-buffer-list)) - (erc-log-setup-logging buffer))) + (erc-log-setup-logging buffer)) + (erc--modify-local-map t "C-c C-l" #'erc-save-buffer-in-logs)) ;; disable ((remove-hook 'erc-insert-post-hook #'erc-save-buffer-in-logs) (remove-hook 'erc-send-post-hook #'erc-save-buffer-in-logs) @@ -241,9 +242,8 @@ log (remove-hook 'erc-part-hook #'erc-conditional-save-buffer) (remove-hook 'erc-connect-pre-hook #'erc-log-setup-logging) (dolist (buffer (erc-buffer-list)) - (erc-log-disable-logging buffer)))) - -(define-key erc-mode-map "\C-c\C-l" #'erc-save-buffer-in-logs) + (erc-log-disable-logging buffer)) + (erc--modify-local-map nil "C-c C-l" #'erc-save-buffer-in-logs))) ;;; functionality referenced from erc.el (defun erc-log-setup-logging (buffer) diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el index 52ee5c855f3..7ec9078d493 100644 --- a/lisp/erc/erc-match.el +++ b/lisp/erc/erc-match.el @@ -52,8 +52,10 @@ match `erc-current-nick-highlight-type'. For all these highlighting types, you can decide whether the entire message or only the sending nick is highlighted." - ((add-hook 'erc-insert-modify-hook #'erc-match-message 'append)) - ((remove-hook 'erc-insert-modify-hook #'erc-match-message))) + ((add-hook 'erc-insert-modify-hook #'erc-match-message 'append) + (erc--modify-local-map t "C-c C-k" #'erc-go-to-log-matches-buffer)) + ((remove-hook 'erc-insert-modify-hook #'erc-match-message) + (erc--modify-local-map nil "C-c C-k" #'erc-go-to-log-matches-buffer))) ;; Remaining customizations @@ -647,8 +649,6 @@ erc-go-to-log-matches-buffer (get-buffer (car buffer-cons)))))) (switch-to-buffer buffer-name))) -(define-key erc-mode-map "\C-c\C-k" #'erc-go-to-log-matches-buffer) - (defun erc-hide-fools (match-type _nickuserhost _message) "Hide foolish comments. This function should be called from `erc-text-matched-hook'." diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 017f72476b1..60fe0480412 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -1209,7 +1209,6 @@ erc-mode-map (define-key map [home] #'erc-bol) (define-key map "\C-c\C-a" #'erc-bol) (define-key map "\C-c\C-b" #'erc-switch-to-buffer) - (define-key map "\C-c\C-c" #'erc-toggle-interpret-controls) (define-key map "\C-c\C-d" #'erc-input-action) (define-key map "\C-c\C-e" #'erc-toggle-ctcp-autoresponse) (define-key map "\C-c\C-f" #'erc-toggle-flood-control) @@ -1233,6 +1232,19 @@ erc-mode-map map) "ERC keymap.") +(defun erc--modify-local-map (mode &rest bindings) + "Modify `erc-mode-map' on behalf of a global module. +Add or remove `key-valid-p' BINDINGS when toggling MODE." + (declare (indent 1)) + (while (pcase-let* ((`(,key ,def . ,rest) bindings) + (existing (keymap-lookup erc-mode-map key))) + (if mode + (when (or (not existing) (eq existing #'undefined)) + (keymap-set erc-mode-map key def)) + (when (eq existing def) + (keymap-unset erc-mode-map key t))) + (setq bindings rest)))) + ;; Faces ; Honestly, I have a horrible sense of color and the "defaults" below diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index 81381a0c800..0c7b06da436 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -492,6 +492,50 @@ erc--target-from-string (should (equal (erc--target-from-string "&Bitlbee") #s(erc--target-channel-local "&Bitlbee" &bitlbee))))) +(ert-deftest erc--modify-local-map () + (when (and (bound-and-true-p erc-irccontrols-mode) + (fboundp 'erc-irccontrols-mode)) + (erc-irccontrols-mode -1)) + (when (and (bound-and-true-p erc-match-mode) + (fboundp 'erc-match-mode)) + (erc-match-mode -1)) + (let* (calls + (inhibit-message noninteractive) + (cmd-foo (lambda () (interactive) (push 'foo calls))) + (cmd-bar (lambda () (interactive) (push 'bar calls)))) + + (ert-info ("Add non-existing") + (erc--modify-local-map t "C-c C-c" cmd-foo "C-c C-k" cmd-bar) + (with-temp-buffer + (set-window-buffer (selected-window) (current-buffer)) + (use-local-map erc-mode-map) + (execute-kbd-macro "\C-c\C-c") + (execute-kbd-macro "\C-c\C-k")) + (should (equal calls '(bar foo)))) + (setq calls nil) + + (ert-info ("Add existing") ; Attempt to swap definitions fails + (erc--modify-local-map t "C-c C-c" cmd-bar "C-c C-k" cmd-foo) + (with-temp-buffer + (set-window-buffer (selected-window) (current-buffer)) + (use-local-map erc-mode-map) + (execute-kbd-macro "\C-c\C-c") + (execute-kbd-macro "\C-c\C-k")) + (should (equal calls '(bar foo)))) + (setq calls nil) + + (ert-info ("Remove existing") + (ert-with-message-capture messages + (erc--modify-local-map nil "C-c C-c" cmd-foo "C-c C-k" cmd-bar) + (with-temp-buffer + (set-window-buffer (selected-window) (current-buffer)) + (use-local-map erc-mode-map) + (execute-kbd-macro "\C-c\C-c") + (execute-kbd-macro "\C-c\C-k")) + (should (string-search "C-c C-c is undefined" messages)) + (should (string-search "C-c C-k is undefined" messages)) + (should-not calls))))) + (ert-deftest erc-ring-previous-command-base-case () (ert-info ("Create ring when nonexistent and do nothing") (let (erc-input-ring commit 5011554529bb874390edfc3060aee960b38e5aff Author: F. Jason Park Date: Thu Jan 19 21:07:27 2023 -0800 Don't require erc-goodies in erc.el * lisp/erc/erc-goodies.el: Obviate the need for forward declarations by requiring `erc'. Add minor-mode autoloads for `scrolltobottom', `readonly', `move-to-prompt', `keep-place', `noncommands', `irccontrols', `smiley', and `unmorse'. Add Local variables footer with `generated-autoload-file'. (erc-controls-strip): Autoload this function. * lisp/erc/erc-ibuffer.el: Require `erc-goodies' for `erc-control-interpret'. The justification for the blanket `require' is this module isn't a member of `erc-modules' by default. * lisp/erc/erc-page.el: (erc-ctcp-query-PAGE): Require `erc-goodies' and put forward declaration for `erc-control-interpret' atop file. * lisp/erc/erc-speedbar.el: Require `erc-goodies' for the same reason as erc-ibuffer.el. * lisp/erc/erc.el: Remove `require' for `erc-goodies' at end of file and `pp' at top of file because `pp-to-string' is autoloaded on Emacs 27. Also remove `require's for `thingatpt', `time-date', and `iso8601'. They're all used sparingly and the latter two have only been around for one major release, so their removal likely won't cause much churn. And `thingatpt' already has a call-site `require', so the top-level one is redundant, but autoload `word-at-point' anyway for the benefit of third-party libraries like `hl-nicks'. Also wrap local loaddefs `require' call in `eval-and-compile'. (erc--read-time-period): Require dependencies. (Bug#60954.) diff --git a/lisp/erc/erc-goodies.el b/lisp/erc/erc-goodies.el index 05a21019042..7ca155ef9d0 100644 --- a/lisp/erc/erc-goodies.el +++ b/lisp/erc/erc-goodies.el @@ -29,23 +29,10 @@ ;;; Code: -;;; Imenu support - (eval-when-compile (require 'cl-lib)) -(require 'erc-common) - (defvar erc-controls-highlight-regexp) (defvar erc-controls-remove-regexp) -(defvar erc-input-marker) -(defvar erc-insert-marker) -(defvar erc-server-process) -(defvar erc-modules) -(defvar erc-log-p) - -(declare-function erc-buffer-list "erc" (&optional predicate proc)) -(declare-function erc-error "erc" (&rest args)) -(declare-function erc-extract-command-from-line "erc" (line)) -(declare-function erc-beg-of-input-line "erc" nil) +(require 'erc) (defun erc-imenu-setup () "Setup Imenu support in an ERC buffer." @@ -65,6 +52,7 @@ erc-input-line-position :group 'erc-display :type '(choice integer (const nil))) +;;;###autoload(autoload 'erc-scrolltobottom-mode "erc-goodies" nil t) (define-erc-module scrolltobottom nil "This mode causes the prompt to stay at the end of the window." ((add-hook 'erc-mode-hook #'erc-add-scroll-to-bottom) @@ -116,6 +104,7 @@ erc-scroll-to-bottom (recenter (or erc-input-line-position -1))))))) ;;; Make read only +;;;###autoload(autoload 'erc-readonly-mode "erc-goodies" nil t) (define-erc-module readonly nil "This mode causes all inserted text to be read-only." ((add-hook 'erc-insert-post-hook #'erc-make-read-only) @@ -131,6 +120,7 @@ erc-make-read-only (put-text-property (point-min) (point-max) 'rear-nonsticky t)) ;;; Move to prompt when typing text +;;;###autoload(autoload 'erc-move-to-prompt-mode "erc-goodies" nil t) (define-erc-module move-to-prompt nil "This mode causes the point to be moved to the prompt when typing text." ((add-hook 'erc-mode-hook #'erc-move-to-prompt-setup) @@ -155,6 +145,7 @@ erc-move-to-prompt-setup (add-hook 'pre-command-hook #'erc-move-to-prompt nil t)) ;;; Keep place in unvisited channels +;;;###autoload(autoload 'erc-keep-place-mode "erc-goodies" nil t) (define-erc-module keep-place nil "Leave point above un-viewed text in other channels." ((add-hook 'erc-insert-pre-hook #'erc-keep-place)) @@ -193,6 +184,7 @@ erc-noncommands-list If a command's function symbol is in this list, the typed command does not appear in the ERC buffer after the user presses ENTER.") +;;;###autoload(autoload 'erc-noncommands-mode "erc-goodies" nil t) (define-erc-module noncommands nil "This mode distinguishes non-commands. Commands listed in `erc-insert-this' know how to display @@ -381,6 +373,7 @@ erc-get-fg-color-face (intern (concat "fg:erc-color-face" (number-to-string n)))) (t (erc-log (format " Wrong color: %s" n)) 'default)))) +;;;###autoload(autoload 'erc-irccontrols-mode "erc-goodies" nil t) (define-erc-module irccontrols nil "This mode enables the interpretation of IRC control chars." ((add-hook 'erc-insert-modify-hook #'erc-controls-highlight) @@ -440,6 +433,7 @@ erc-controls-interpret s)) (t s))))) +;;;###autoload (defun erc-controls-strip (str) "Return a copy of STR with all IRC control characters removed." (when str @@ -553,6 +547,7 @@ erc-toggle-interpret-controls (if erc-interpret-controls-p "ON" "OFF"))) ;; Smiley +;;;###autoload(autoload 'erc-smiley-mode "erc-goodies" nil t) (define-erc-module smiley nil "This mode translates text-smileys such as :-) into pictures. This requires the function `smiley-region', which is defined in @@ -569,6 +564,7 @@ erc-smiley (smiley-region (point-min) (point-max)))) ;; Unmorse +;;;###autoload(autoload 'erc-unmorse-mode "erc-goodies" nil t) (define-erc-module unmorse nil "This mode causes morse code in the current channel to be unmorsed." ((add-hook 'erc-insert-modify-hook #'erc-unmorse)) @@ -611,3 +607,7 @@ erc-occur (provide 'erc-goodies) ;;; erc-goodies.el ends here + +;; Local Variables: +;; generated-autoload-file: "erc-loaddefs.el" +;; End: diff --git a/lisp/erc/erc-ibuffer.el b/lisp/erc/erc-ibuffer.el index 6699afe36a0..612814ac6da 100644 --- a/lisp/erc/erc-ibuffer.el +++ b/lisp/erc/erc-ibuffer.el @@ -32,6 +32,7 @@ (require 'ibuffer) (require 'ibuf-ext) (require 'erc) +(require 'erc-goodies) ; `erc-controls-interpret' (defgroup erc-ibuffer nil "The Ibuffer group for ERC." diff --git a/lisp/erc/erc-page.el b/lisp/erc/erc-page.el index 6cba59c6946..a94678e5132 100644 --- a/lisp/erc/erc-page.el +++ b/lisp/erc/erc-page.el @@ -30,6 +30,8 @@ (require 'erc) +(declare-function erc-controls-interpret "erc-goodies" (str)) + (defgroup erc-page nil "React to CTCP PAGE messages." :group 'erc) @@ -70,6 +72,7 @@ erc-ctcp-query-PAGE This will call `erc-page-function', if defined, or it will just print a message and `beep'. In addition to that, the page message is also inserted into the server buffer." + (require 'erc-goodies) ; for `erc-controls-interpret' (when (and erc-page-mode (string-match "PAGE\\(\\s-+.*\\)?$" msg)) (let* ((m (match-string 1 msg)) diff --git a/lisp/erc/erc-speedbar.el b/lisp/erc/erc-speedbar.el index 5fca14e2365..a9443e0ea17 100644 --- a/lisp/erc/erc-speedbar.el +++ b/lisp/erc/erc-speedbar.el @@ -36,6 +36,7 @@ ;;; Code: (require 'erc) +(require 'erc-goodies) (require 'speedbar) (condition-case nil (require 'dframe) (error nil)) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 27e9ec81b98..017f72476b1 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -58,17 +58,13 @@ ;;; Code: -(load "erc-loaddefs" 'noerror 'nomessage) +(eval-and-compile (load "erc-loaddefs" 'noerror 'nomessage)) (require 'erc-networks) (require 'erc-backend) (require 'cl-lib) (require 'format-spec) -(require 'pp) -(require 'thingatpt) (require 'auth-source) -(require 'time-date) -(require 'iso8601) (eval-when-compile (require 'subr-x) (require 'url-parse)) (defconst erc-version "5.6-git" @@ -141,6 +137,11 @@ tabbar--local-hlf (defvar motif-version-string) (defvar gtk-version-string) +(declare-function decoded-time-period "time-date" (time)) +(declare-function iso8601-parse-duration "iso8601" (string)) +(declare-function word-at-point "thingatpt" (&optional no-properties)) +(autoload 'word-at-point "thingatpt") ; for hl-nicks + ;; tunable connection and authentication parameters (defcustom erc-server nil @@ -3102,6 +3103,8 @@ erc--read-time-period (string-to-number period)) ;; Parse as a time spec. (t + (require 'time-date) + (require 'iso8601) (let ((time (condition-case nil (iso8601-parse-duration (concat (cond @@ -6933,8 +6936,6 @@ erc-format-lag-time (cond (lag (format "lag:%.0f" lag)) (t "")))) -;; erc-goodies is required at end of this file. - ;; TODO when ERC drops Emacs 28, replace the expressions in the format ;; spec below with functions. (defun erc-update-mode-line-buffer (buffer) @@ -7484,6 +7485,4 @@ erc-handle-irc-url (provide 'erc) -;; FIXME this is a temporary stopgap for Emacs 29. -(require 'erc-goodies) ;;; erc.el ends here commit 3d81ecf0a95374793f70a19da81ea75da84d0be1 Author: F. Jason Park Date: Sat Feb 4 06:24:59 2023 -0800 Leverage loaddefs for migrating ERC modules * lisp/erc/erc-common.el (erc--features-to-modules, erc--modules-to-features, erc--module-name-migrations): Remove unused internal functions. (erc--normalize-module-symbol): Make aware of new migration scheme based on symbol properties. * lisp/erc/erc-page.el: Add autoload cookie for module migration. * lisp/erc/erc-pcomplete.el: Add autoload cookies for module migration. * lisp/erc/erc-services.el: Add autoload cookie for module migration. * lisp/erc/erc-sound.el: Add autoload cookie for module migration. * lisp/erc/erc-stamp.el: Add autoload cookie for module migration. * lisp/erc/erc.el (erc-modules): Reorder default value, sorted by `string<' so that Customize does not consider the value to have been edited. Remove non-existent module `hecomplete' from lineup and swap a couple more to maintain sorted order. Change `:initialize' function to tag all symbols for built-in modules with an `erc--module' property. In the `:set' function, ensure third-party modules appear after the sorted and normalized built-ins, but in user-defined order. Do this to prevent all modules, built-ins included, from ending up as populated form fields for the "other" checkbox in the Customize interface. (erc--find-mode): Add helper function for `erc--update-modules'. (erc--update-modules): Always resolve module names and only conditionally attempt to require corresponding features. * test/lisp/erc/erc-tests.el (erc-tests--modules): Add manifest for asserting built-in modules and features. This is easier to verify visually than looking at the custom-type set for `erc-modules'. (erc-modules--initialize): New test. (erc-modules--internal-property): Add test. (erc--normalize-module-symbol): New test. (erc--find-mode): New test. (erc--update-modules) Adapt to new paradigm and make more comprehensive. (Bug#60954.) diff --git a/lisp/erc/erc-common.el b/lisp/erc/erc-common.el index 0279b0a0bc4..b8f6a06b76c 100644 --- a/lisp/erc/erc-common.el +++ b/lisp/erc/erc-common.el @@ -85,40 +85,13 @@ 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.") - +;; After dropping 28, we can use prefixed "erc-autoload" cookies. (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)) + "Return preferred SYMBOL for `erc--modules'." + (while-let ((canonical (get symbol 'erc--module)) + ((not (eq canonical symbol)))) + (setq symbol canonical)) + symbol) (defun erc--assemble-toggle (localp name ablsym mode val body) (let ((arg (make-symbol "arg"))) diff --git a/lisp/erc/erc-page.el b/lisp/erc/erc-page.el index 308b3784ca5..6cba59c6946 100644 --- a/lisp/erc/erc-page.el +++ b/lisp/erc/erc-page.el @@ -34,6 +34,7 @@ erc-page "React to CTCP PAGE messages." :group 'erc) +;;;###autoload(put 'ctcp-page 'erc--module 'page) ;;;###autoload(autoload 'erc-page-mode "erc-page") (define-erc-module page ctcp-page "Process CTCP PAGE requests from IRC." diff --git a/lisp/erc/erc-pcomplete.el b/lisp/erc/erc-pcomplete.el index 0bce856018c..7eb7431fb91 100644 --- a/lisp/erc/erc-pcomplete.el +++ b/lisp/erc/erc-pcomplete.el @@ -56,6 +56,8 @@ erc-pcomplete-order-nickname-completions "If t, order nickname completions with the most recent speakers first." :type 'boolean) +;;;###autoload(put 'Completion 'erc--module 'completion) +;;;###autoload(put 'pcomplete 'erc--module 'completion) ;;;###autoload(autoload 'erc-completion-mode "erc-pcomplete" nil t) (define-erc-module pcomplete Completion "In ERC Completion mode, the TAB key does completion whenever possible." diff --git a/lisp/erc/erc-services.el b/lisp/erc/erc-services.el index 2e6959cc3f0..5408ba405db 100644 --- a/lisp/erc/erc-services.el +++ b/lisp/erc/erc-services.el @@ -102,6 +102,7 @@ erc-nickserv-identify-mode (when (featurep 'erc-services) (erc-nickserv-identify-mode val)))) +;;;###autoload(put 'nickserv 'erc--module 'services) ;;;###autoload(autoload 'erc-services-mode "erc-services" nil t) (define-erc-module services nickserv "This mode automates communication with services." diff --git a/lisp/erc/erc-sound.el b/lisp/erc/erc-sound.el index 0abdbfd959c..9da9202f0cf 100644 --- a/lisp/erc/erc-sound.el +++ b/lisp/erc/erc-sound.el @@ -47,6 +47,7 @@ (require 'erc) +;;;###autoload(put 'ctcp-sound 'erc--module 'sound) ;;;###autoload(autoload 'erc-sound-mode "erc-sound") (define-erc-module sound ctcp-sound "In ERC sound mode, the client will respond to CTCP SOUND requests diff --git a/lisp/erc/erc-stamp.el b/lisp/erc/erc-stamp.el index 0aa1590f801..d1a1507f700 100644 --- a/lisp/erc/erc-stamp.el +++ b/lisp/erc/erc-stamp.el @@ -147,6 +147,10 @@ erc-timestamp-face "ERC timestamp face." :group 'erc-faces) +;; New libraries should only autoload the minor mode for a module's +;; preferred name (rather than its alias). + +;;;###autoload(put 'timestamp 'erc--module 'stamp) ;;;###autoload(autoload 'erc-timestamp-mode "erc-stamp" nil t) (define-erc-module stamp timestamp "This mode timestamps messages in the channel buffers." diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index ef51f100f8b..27e9ec81b98 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -1839,9 +1839,9 @@ erc-migrate-modules ;; each item is in the format '(old . new) (delete-dups (mapcar #'erc--normalize-module-symbol mods))) -(defcustom erc-modules '(netsplit fill button match track completion readonly - networks ring autojoin noncommands irccontrols - move-to-prompt stamp menu list) +(defcustom erc-modules '( autojoin button completion fill irccontrols + list match menu move-to-prompt netsplit + networks noncommands readonly ring stamp track) "A list of modules which ERC should enable. If you set the value of this without using `customize' remember to call \(erc-update-modules) after you change it. When using `customize', modules @@ -1849,12 +1849,20 @@ erc-modules :get (lambda (sym) ;; replace outdated names with their newer equivalents (erc-migrate-modules (symbol-value sym))) - :initialize #'custom-initialize-default + ;; Expect every built-in module to have the symbol property + ;; `erc--module' set to its canonical symbol (often itself). + :initialize (lambda (symbol exp) + ;; Use `cdddr' because (set :greedy t . ,entries) + (dolist (entry (cdddr (get 'erc-modules 'custom-type))) + (when-let* (((eq (car entry) 'const)) + (s (cadddr entry))) ; (const :tag "..." ,s) + (put s 'erc--module s))) + (custom-initialize-reset symbol exp)) :set (lambda (sym val) ;; disable modules which have just been removed (when (and (boundp 'erc-modules) erc-modules val) (dolist (module erc-modules) - (unless (member module val) + (unless (memq module val) (let ((f (intern-soft (format "erc-%s-mode" module)))) (when (and (fboundp f) (boundp f)) (when (symbol-value f) @@ -1866,7 +1874,15 @@ erc-modules (when (symbol-value f) (funcall f 0)) (kill-local-variable f))))))))) - (set sym val) + (let (built-in third-party) + (dolist (v val) + (setq v (erc--normalize-module-symbol v)) + (if (get v 'erc--module) + (push v built-in) + (push v third-party))) + ;; Calling `set-default-toplevel-value' complicates testing + (set sym (append (sort built-in #'string-lessp) + (nreverse third-party)))) ;; this test is for the case where erc hasn't been loaded yet (when (fboundp 'erc-update-modules) (erc-update-modules))) @@ -1880,7 +1896,6 @@ erc-modules capab-identify) (const :tag "completion: Complete nicknames and commands (programmable)" completion) - (const :tag "hecomplete: Complete nicknames and commands (obsolete, use \"completion\")" hecomplete) (const :tag "dcc: Provide Direct Client-to-Client support" dcc) (const :tag "fill: Wrap long lines" fill) (const :tag "identd: Launch an identd server on port 8113" identd) @@ -1897,11 +1912,11 @@ erc-modules (const :tag "networks: Provide data about IRC networks" networks) (const :tag "noncommands: Don't display non-IRC commands after evaluation" noncommands) + (const :tag "notifications: Desktop alerts on PRIVMSG or mentions" + notifications) (const :tag "notify: Notify when the online status of certain users changes" notify) - (const :tag "notifications: Send notifications on PRIVMSG or nickname mentions" - notifications) (const :tag "page: Process CTCP PAGE requests from IRC" page) (const :tag "readonly: Make displayed lines read-only" readonly) (const :tag "replace: Replace text in messages" replace) @@ -1914,8 +1929,8 @@ erc-modules (const :tag "smiley: Convert smileys to pretty icons" smiley) (const :tag "sound: Play sounds when you receive CTCP SOUND requests" sound) - (const :tag "stamp: Add timestamps to messages" stamp) (const :tag "spelling: Check spelling" spelling) + (const :tag "stamp: Add timestamps to messages" stamp) (const :tag "track: Track channel activity in the mode-line" track) (const :tag "truncate: Truncate buffers to a certain size" truncate) (const :tag "unmorse: Translate morse code in messages" unmorse) @@ -1929,18 +1944,28 @@ erc-update-modules (erc--update-modules) nil) +(defun erc--find-mode (sym) + (setq sym (erc--normalize-module-symbol sym)) + (if-let* ((mode (intern-soft (concat "erc-" (symbol-name sym) "-mode"))) + ((or (boundp mode) + (and (fboundp mode) + (autoload-do-load (symbol-function mode) mode))))) + mode + (and (require (or (get sym 'erc--feature) + (intern (concat "erc-" (symbol-name sym)))) + nil 'noerror) + (setq mode (intern-soft (concat "erc-" (symbol-name sym) "-mode"))) + (fboundp mode) + mode))) + (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)))))) + (if-let ((mode (erc--find-mode module))) + (if (custom-variable-p mode) + (funcall mode 1) + (push mode local-modes)) + (error "`%s' is not a known ERC module" module))))) (defun erc-setup-buffer (buffer) "Consults `erc-join-buffer' to find out how to display `BUFFER'." diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index bbf3269161d..81381a0c800 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -1224,6 +1224,85 @@ erc-handle-irc-url (kill-buffer "baznet") (kill-buffer "#chan"))) +(defconst erc-tests--modules + '( autoaway autojoin button capab-identify completion dcc fill identd + irccontrols keep-place list log match menu move-to-prompt netsplit + networks noncommands notifications notify page readonly + replace ring sasl scrolltobottom services smiley sound + spelling stamp track truncate unmorse xdcc)) + +;; Ensure that `:initialize' doesn't change the ordering of the +;; members because otherwise the widget's state is "edited". + +(ert-deftest erc-modules--initialize () + ;; This is `custom--standard-value' from Emacs 28. + (should (equal (eval (car (get 'erc-modules 'standard-value)) t) + erc-modules))) + +;; Ensure the `:initialize' function for `erc-modules' successfully +;; tags all built-in modules with the internal property `erc--module'. + +(ert-deftest erc-modules--internal-property () + (let (ours) + (mapatoms (lambda (s) + (when-let ((v (get s 'erc--module)) + ((eq v s))) + (push s ours)))) + (should (equal (sort ours #'string-lessp) erc-tests--modules)))) + +(ert-deftest erc--normalize-module-symbol () + (dolist (mod erc-tests--modules) + (should (eq (erc--normalize-module-symbol mod) mod))) + (should (eq (erc--normalize-module-symbol 'pcomplete) 'completion)) + (should (eq (erc--normalize-module-symbol 'Completion) 'completion)) + (should (eq (erc--normalize-module-symbol 'ctcp-page) 'page)) + (should (eq (erc--normalize-module-symbol 'ctcp-sound) 'sound)) + (should (eq (erc--normalize-module-symbol 'timestamp) 'stamp)) + (should (eq (erc--normalize-module-symbol 'nickserv) 'services))) + +;; Worrying about which library a module comes from is mostly not +;; worth the hassle so long as ERC can find its minor mode. However, +;; bugs involving multiple modules living in the same library may slip +;; by because a module's loading problems may remain hidden on account +;; of its place in the default ordering. + +(ert-deftest erc--find-mode () + (let* ((package (if-let* ((found (getenv "ERC_PACKAGE_NAME")) + ((string-prefix-p "erc-" found))) + (intern found) + 'erc)) + (prog + `(,@(and (featurep 'compat) + `((progn + (require 'package) + (let ((package-load-list '((compat t) (,package t)))) + (package-initialize))))) + (require 'erc) + (let ((mods (mapcar #'cadddr + (cdddr (get 'erc-modules 'custom-type)))) + moded) + (setq mods + (sort mods (lambda (a b) (if (zerop (random 2)) a b)))) + (dolist (mod mods) + (unless (keywordp mod) + (push (if-let ((mode (erc--find-mode mod))) + mod + (list :missing mod)) + moded))) + (message "%S" + (sort moded + (lambda (a b) + (string< (symbol-name a) (symbol-name b)))))))) + (proc (start-process "erc--module-mode-autoloads" + (current-buffer) + (concat invocation-directory invocation-name) + "-batch" "-Q" + "-eval" (format "%S" (cons 'progn prog))))) + (set-process-query-on-exit-flag proc t) + (while (accept-process-output proc 10)) + (goto-char (point-min)) + (should (equal (read (current-buffer)) erc-tests--modules)))) + (ert-deftest erc-migrate-modules () (should (equal (erc-migrate-modules '(autojoin timestamp button)) '(autojoin stamp button))) @@ -1234,17 +1313,28 @@ erc--update-modules (let (calls erc-modules erc-kill-channel-hook erc-kill-server-hook erc-kill-buffer-hook) + + ;; This `lbaz' module is unknown, so ERC looks for it via the + ;; symbol proerty `erc--feature' and, failing that, by + ;; `require'ing its "erc-" prefixed symbol. + (should-not (intern-soft "erc-lbaz-mode")) + (cl-letf (((symbol-function 'require) - (lambda (s &rest _) (push s calls))) + (lambda (s &rest _) + (when (eq s 'erc--lbaz-feature) + (fset (intern "erc-lbaz-mode") ; local module + (lambda (n) (push (cons 'lbaz n) calls)))) + (push s calls))) ;; Local modules - ((symbol-function 'erc-fake-bar-mode) - (lambda (n) (push (cons 'fake-bar n) calls))) + ((symbol-function 'erc-lbar-mode) + (lambda (n) (push (cons 'lbar n) calls))) + ((get 'lbaz 'erc--feature) 'erc--lbaz-feature) ;; 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-gfoo-mode) + (lambda (n) (push (cons 'gfoo n) calls))) + ((get 'erc-gfoo-mode 'standard-value) 'ignore) ((symbol-function 'erc-autojoin-mode) (lambda (n) (push (cons 'autojoin n) calls))) ((get 'erc-autojoin-mode 'standard-value) 'ignore) @@ -1255,20 +1345,28 @@ erc--update-modules (lambda (n) (push (cons 'completion n) calls))) ((get 'erc-completion-mode 'standard-value) 'ignore)) + (ert-info ("Unknown module") + (setq erc-modules '(lfoo)) + (should-error (erc--update-modules)) + (should (equal (pop calls) 'erc-lfoo)) + (should-not calls)) + (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 erc-modules '(gfoo lbar lbaz)) + ;; Don't expose the mode here + (should (equal (mapcar #'symbol-name (erc--update-modules)) + '("erc-lbaz-mode" "erc-lbar-mode"))) + ;; Lbaz required because unknown. + (should (equal (nreverse calls) '((gfoo . 1) erc--lbaz-feature))) + (fmakunbound (intern "erc-lbaz-mode")) + (unintern (intern "erc-lbaz-mode") obarray) (setq calls nil)) - (ert-info ("Module name overrides") - (setq erc-modules '(completion autojoin networks)) + (ert-info ("Global modules") ; `pcomplete' resolved to `completion' + (setq erc-modules '(pcomplete 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)))) + (should (equal (nreverse calls) + '((completion . 1) (autojoin . 1) (networks . 1)))) (setq calls nil))))) (ert-deftest erc--merge-local-modes () commit 89815631f242076b3cf2fda370f6eca522299340 Author: F. Jason Park Date: Thu Jan 19 20:52:47 2023 -0800 Copy over upstream Compat macros to erc-compat * lisp/erc/erc-backend: (erc--get-isupport-entry): Replace call to `erc-compat--with-memoization' with the built-in `with-memoization'. * lisp/erc/erc-compat.el: (erc-compat-function, erc-compat-call): Add new macros from Compat 29.1.2.0. (erc-compat--with-memoization): Remove because it's now provided by Compat. (Bug#60954.) diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 84d6b8a7efd..bdf4e2ddca2 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -1984,7 +1984,7 @@ erc--get-isupport-entry primitive value." (if-let* ((table (or erc--isupport-params (erc-with-server-buffer erc--isupport-params))) - (value (erc-compat--with-memoization (gethash key table) + (value (with-memoization (gethash key table) (when-let ((v (assoc (symbol-name key) erc-server-parameters))) (if (cdr v) diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el index e6ae62d3a2e..10a495211cc 100644 --- a/lisp/erc/erc-compat.el +++ b/lisp/erc/erc-compat.el @@ -34,6 +34,49 @@ (require 'compat nil 'noerror) (eval-when-compile (require 'cl-lib) (require 'url-parse)) +;; Except for the "erc-" namespacing, these two definitions should be +;; continuously updated to match the latest upstream ones verbatim. +;; Although they're pretty simple, it's likely not worth checking for +;; and possibly deferring to the non-prefixed versions. +;; +;; BEGIN Compat macros + +;;;; Macros for extended compatibility function calls + +(defmacro erc-compat-function (fun) + "Return compatibility function symbol for FUN. + +If the Emacs version provides a sufficiently recent version of +FUN, the symbol FUN is returned itself. Otherwise the macro +returns the symbol of a compatibility function which supports the +behavior and calling convention of the current stable Emacs +version. For example Compat 29.1 will provide compatibility +functions which implement the behavior and calling convention of +Emacs 29.1. + +See also `compat-call' to directly call compatibility functions." + (let ((compat (intern (format "compat--%s" fun)))) + `#',(if (fboundp compat) compat fun))) + +(defmacro erc-compat-call (fun &rest args) + "Call compatibility function or macro FUN with ARGS. + +A good example function is `plist-get' which was extended with an +additional predicate argument in Emacs 29.1. The compatibility +function, which supports this additional argument, can be +obtained via (compat-function plist-get) and called +via (compat-call plist-get plist prop predicate). It is not +possible to directly call (plist-get plist prop predicate) on +Emacs older than 29.1, since the original `plist-get' function +does not yet support the predicate argument. Note that the +Compat library never overrides existing functions. + +See also `compat-function' to lookup compatibility functions." + (let ((compat (intern (format "compat--%s" fun)))) + `(,(if (fboundp compat) compat fun) ,@args))) + +;; END Compat macros + ;;;###autoload(autoload 'erc-define-minor-mode "erc-compat") (define-obsolete-function-alias 'erc-define-minor-mode #'define-minor-mode "28.1") @@ -368,15 +411,6 @@ erc-compat--29-sasl-scram--client-final-message ;;;; Misc 29.1 -(defmacro erc-compat--with-memoization (table &rest forms) - (declare (indent defun)) - (cond - ((fboundp 'with-memoization) - `(with-memoization ,table ,@forms)) ; 29.1 - ((fboundp 'cl--generic-with-memoization) - `(cl--generic-with-memoization ,table ,@forms)) - (t `(progn ,@forms)))) - (defvar url-irc-function) (defun erc-compat--29-browse-url-irc (string &rest _) commit e69bd59ec59784b2f646e93355d4d63f41426cfc Author: F. Jason Park Date: Sat Feb 18 19:32:36 2023 -0800 Honor arbitrary CHANTYPES in ERC * lisp/erc/erc.el (erc-channel-p): Favor "CHANTYPES" ISUPPORT item before falling back to well known prefixes. * test/lisp/erc/erc-tests.el (erc-channel-p): Add test. Arbitrarily bundled with bug#60954. diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 6d35a62518d..ef51f100f8b 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -1549,10 +1549,14 @@ erc-reuse-frames (defun erc-channel-p (channel) "Return non-nil if CHANNEL seems to be an IRC channel name." (cond ((stringp channel) - (memq (aref channel 0) '(?# ?& ?+ ?!))) - ((and (bufferp channel) (buffer-live-p channel)) - (with-current-buffer channel - (erc-channel-p (erc-default-target)))) + (memq (aref channel 0) + (if-let ((types (erc--get-isupport-entry 'CHANTYPES 'single))) + (append types nil) + '(?# ?& ?+ ?!)))) + ((and-let* (((bufferp channel)) + ((buffer-live-p channel)) + (target (buffer-local-value 'erc--target channel))) + (erc-channel-p (erc--target-string target)))) (t nil))) ;; For the sake of compatibility, a historical quirk concerning this diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index d6c63934163..bbf3269161d 100644 --- a/test/lisp/erc/erc-tests.el +++ b/test/lisp/erc/erc-tests.el @@ -447,6 +447,27 @@ erc-downcase (should (equal (erc-downcase "Tilde~") "tilde~" )) (should (equal (erc-downcase "\\O/") "|o/" ))))) +(ert-deftest erc-channel-p () + (let ((erc--isupport-params (make-hash-table)) + erc-server-parameters) + + (should (erc-channel-p "#chan")) + (should (erc-channel-p "##chan")) + (should (erc-channel-p "&chan")) + (should (erc-channel-p "+chan")) + (should (erc-channel-p "!chan")) + (should-not (erc-channel-p "@chan")) + + (push '("CHANTYPES" . "#&@+!") erc-server-parameters) + + (should (erc-channel-p "!chan")) + (should (erc-channel-p "#chan")) + + (with-current-buffer (get-buffer-create "#chan") + (setq erc--target (erc--target-from-string "#chan"))) + (should (erc-channel-p (get-buffer "#chan")))) + (kill-buffer "#chan")) + (ert-deftest erc--valid-local-channel-p () (ert-info ("Local channels not supported") (let ((erc--isupport-params (make-hash-table))) commit 8c0c98268440b27a77faf30738dfd72c909bb33f Author: F. Jason Park Date: Thu Apr 6 18:41:06 2023 -0700 Add hook to regain nickname in ERC * lisp/erc/erc-backend.el (erc-server-reconnect-timeout): Mention `erc-nickname-in-use-functions' in doc string. * lisp/erc/erc.el (erc-nickname-in-use-functions, erc-regain-nick-on-connect): Add abnormal hook and possible value to handle stale connections preventing a desired nick from being reissued by the server. Follows directly from bug#62044. (erc-nickname-in-use): Call `erc-nickname-in-use-functions'. * test/lisp/erc/erc-scenarios-base-renick.el (erc-scenarios-base-renick-auto-regain): New test. * test/lisp/erc/resources/base/renick/regain/normal-again.eld: New file. * test/lisp/erc/resources/base/renick/regain/normal.eld: New file. diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index acfbe3ef3a6..84d6b8a7efd 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -418,7 +418,9 @@ erc-server-reconnect-timeout If this value is too low, servers may reject your initial nick request upon reconnecting because they haven't yet noticed that your previous connection is dead. If this happens, try setting -this value to 120 or greater." +this value to 120 or greater and/or exploring the option +`erc-nickname-in-use-functions', which may provide a more +proactive means of handling this situation on some servers." :type 'number) (defcustom erc-server-reconnect-function 'erc-server-delayed-reconnect diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 66bc4985027..6d35a62518d 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -392,6 +392,24 @@ erc-nick-changed-functions :group 'erc-hooks :type 'hook) +(defcustom erc-nickname-in-use-functions nil + "Function to run before trying for a different nickname. +Called with two arguments: the desired but just rejected nickname +and the alternate nickname about to be requested. Use cases +include special handling during connection registration and +wrestling with nickname services. For example, value +`erc-regain-nick-on-connect' is aimed at dealing with reaping +lingering connections that may prevent you from being issued a +requested nick immediately when reconnecting. It's meant to be +used with an `erc-server-reconnect-function' value of +`erc-server-delayed-check-reconnect' alongside SASL +authentication." + :package-version '(ERC . "5.6") + :group 'erc-hooks + :type '(choice (function-item erc-regain-nick-on-connect) + function + (const nil))) + (defcustom erc-connect-pre-hook '(erc-initialize-log-marker) "Hook called just before `erc' calls `erc-connect'. Functions are passed a buffer as the first argument." @@ -4594,6 +4612,34 @@ erc-wash-quit-reason (match-string 1 reason)) reason)) +(defun erc-regain-nick-on-connect (want temp) + "Try at most once to grab nickname WANT after settling for TEMP. +Only do so during connection registration, likely prior to +authenticating with SASL. Assume the prior connection was lost +due to connectivity failure and that the server hasn't yet +noticed. Also assume that the server won't process any +authentication-related messages until it has accepted a mulligan +nick or at least sent a 433 and thus triggered +`erc-nickname-in-use-functions'. Expect authentication to have +succeeded by the time a logical IRC connection has been +established and that the contending connection may otherwise +still be alive and require manual intervention involving +NickServ." + (unless erc-server-connected + (letrec ((after-connect + (lambda (_ nick) + (remove-hook 'erc-after-connect after-connect t) + (when (equal temp nick) + (erc-cmd-NICK want)))) + (on-900 + (lambda (_ parsed) + (remove-hook 'erc-server-900-functions on-900 t) + (unless erc-server-connected + (when (equal (car (erc-response.command-args parsed)) temp) + (add-hook 'erc-after-connect after-connect nil t))) + nil))) + (add-hook 'erc-server-900-functions on-900 nil t)))) + (defun erc-nickname-in-use (nick reason) "If NICK is unavailable, tell the user the REASON. @@ -4627,6 +4673,7 @@ erc-nickname-in-use ;; established a connection yet (- 9 (length erc-nick-uniquifier)))) erc-nick-uniquifier))) + (run-hook-with-args 'erc-nickname-in-use-functions nick newnick) (erc-cmd-NICK newnick) (erc-display-error-notice nil diff --git a/test/lisp/erc/erc-scenarios-base-renick.el b/test/lisp/erc/erc-scenarios-base-renick.el index f1723200533..f8350676fb7 100644 --- a/test/lisp/erc/erc-scenarios-base-renick.el +++ b/test/lisp/erc/erc-scenarios-base-renick.el @@ -303,4 +303,47 @@ erc-scenarios-base-renick-queries-bouncer (should-not (search-forward "now known as frenemy" nil t)) (erc-d-t-search-for 25 "I have lost")))) +;; The server rejects your nick during registration, so ERC acquires a +;; placeholder and successfully renicks once the connection is up. +;; See also `erc-scenarios-base-renick-self-auto'. + +(ert-deftest erc-scenarios-base-renick-auto-regain () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-server-flood-penalty 0.1) + (erc-scenarios-common-dialog "base/renick/regain") + (dumb-server (erc-d-run "localhost" t 'normal 'normal-again)) + (port (process-contact dumb-server :service)) + (erc-server-auto-reconnect t) + (erc-modules (cons 'sasl erc-modules)) + (erc-nickname-in-use-functions '(erc-regain-nick-on-connect)) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Session succeeds but cut short") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :user "tester" + :password "changeme" + :full-name "tester") + (funcall expect 10 "Last login from") + (erc-cmd-JOIN "#test"))) + + (with-current-buffer (erc-d-t-wait-for 10 (get-buffer "#test")) + (funcall expect 10 "was created on")) + + (ert-info ("Service restored") + (with-current-buffer "Libera.Chat" + (erc-d-t-wait-for 10 erc--server-reconnect-timer) + (funcall expect 10 "Connection failed!") + (funcall expect 10 "already in use") + (funcall expect 10 "changed mode for tester`") + (funcall expect 10 "Last login from") + (funcall expect 10 "Your new nickname is tester"))) + + (with-current-buffer (get-buffer "#test") + (funcall expect 10 "tester ") + (funcall expect 10 "was created on")))) + + ;;; erc-scenarios-base-renick.el ends here diff --git a/test/lisp/erc/resources/base/renick/regain/normal-again.eld b/test/lisp/erc/resources/base/renick/regain/normal-again.eld new file mode 100644 index 00000000000..c0529052c70 --- /dev/null +++ b/test/lisp/erc/resources/base/renick/regain/normal-again.eld @@ -0,0 +1,56 @@ +;; -*- mode: lisp-data; -*- +((cap 10 "CAP REQ :sasl")) +((nick 10 "NICK tester")) +((user 10 "USER tester 0 * :tester")) + +((authenticate 10 "AUTHENTICATE PLAIN") + (0.04 ":tantalum.libera.chat NOTICE * :*** Checking Ident") + (0.01 ":tantalum.libera.chat NOTICE * :*** Looking up your hostname...") + (0.01 ":tantalum.libera.chat NOTICE * :*** Couldn't look up your hostname") + (0.06 ":tantalum.libera.chat NOTICE * :*** No Ident response") + (0.02 ":tantalum.libera.chat CAP * ACK :sasl") + (0.03 ":tantalum.libera.chat 433 * tester :Nickname is already in use.")) + +((nick 10 "NICK tester`") + (0.03 "AUTHENTICATE +")) + +((authenticate 10 "AUTHENTICATE AHRlc3RlcgBjaGFuZ2VtZQ==") + (0.06 ":tantalum.libera.chat 900 tester` tester`!tester@127.0.0.1 tester :You are now logged in as tester") + (0.02 ":tantalum.libera.chat 903 tester` :SASL authentication successful")) + +((cap 10 "CAP END") + (0.02 ":tantalum.libera.chat 001 tester` :Welcome to the Libera.Chat Internet Relay Chat Network tester`") + (0.02 ":tantalum.libera.chat 002 tester` :Your host is tantalum.libera.chat[93.158.237.2/6697], running version solanum-1.0-dev") + (0.02 ":tantalum.libera.chat 003 tester` :This server was created Mon Feb 13 2023 at 12:05:04 UTC") + (0.01 ":tantalum.libera.chat 004 tester` tantalum.libera.chat solanum-1.0-dev DGMQRSZaghilopsuwz CFILMPQRSTbcefgijklmnopqrstuvz bkloveqjfI") + (0.01 ":tantalum.libera.chat 005 tester` WHOX MONITOR=100 SAFELIST ELIST=CMNTU ETRACE FNC CALLERID=g KNOCK CHANTYPES=# EXCEPTS INVEX CHANMODES=eIbq,k,flj,CFLMPQRSTcgimnprstuz :are supported by this server") + (0.01 ":tantalum.libera.chat 005 tester` CHANLIMIT=#:250 PREFIX=(ov)@+ MAXLIST=bqeI:100 MODES=4 NETWORK=Libera.Chat STATUSMSG=@+ CASEMAPPING=rfc1459 NICKLEN=16 MAXNICKLEN=16 CHANNELLEN=50 TOPICLEN=390 DEAF=D :are supported by this server") + (0.03 ":tantalum.libera.chat 005 tester` TARGMAX=NAMES:1,LIST:1,KICK:1,WHOIS:1,PRIVMSG:4,NOTICE:4,ACCEPT:,MONITOR: EXTBAN=$,ajrxz :are supported by this server") + (0.01 ":tantalum.libera.chat 251 tester` :There are 70 users and 42977 invisible on 28 servers") + (0.00 ":tantalum.libera.chat 252 tester` 38 :IRC Operators online") + (0.00 ":tantalum.libera.chat 253 tester` 87 :unknown connection(s)") + (0.00 ":tantalum.libera.chat 254 tester` 22908 :channels formed") + (0.00 ":tantalum.libera.chat 255 tester` :I have 2507 clients and 1 servers") + (0.00 ":tantalum.libera.chat 265 tester` 2507 3232 :Current local users 2507, max 3232") + (0.00 ":tantalum.libera.chat 266 tester` 43047 51777 :Current global users 43047, max 51777") + (0.00 ":tantalum.libera.chat 250 tester` :Highest connection count: 3233 (3232 clients) (284887 connections received)") + (0.03 ":tantalum.libera.chat 375 tester` :- tantalum.libera.chat Message of the Day - ") + (0.00 ":tantalum.libera.chat 372 tester` :- This server provided by Hyperfilter (https://hyperfilter.com)") + (0.00 ":tantalum.libera.chat 372 tester` :- Email: support@libera.chat") + (0.02 ":tantalum.libera.chat 376 tester` :End of /MOTD command.")) + +((mode 10 "MODE tester` +i") + (0.01 ":tester` MODE tester` :+Ziw") + (0.02 ":SaslServ!SaslServ@services.libera.chat NOTICE tester` :Last login from: \2~tester@127.0.0.1\2 on Apr 07 01:36:25 2023 +0000.")) + +((nick 10 "NICK tester") + (0.02 ":tester`!~tester@127.0.0.1 NICK :tester")) + +((join 10 "JOIN #test") + (0.02 ":tester!~tester@127.0.0.1 JOIN #test") + (0.02 ":tantalum.libera.chat 353 tester = #test :tester zbyqbepbqre7 pusevgfpu Thrfg2187 zngbeb qnexNssvavgl wrebzr- rqpentt Ilehf grfg2 AvtugZbaxrl pevfgvvbna xrivap_ fnvybePng shohxv gxan arrqyr avpx16 NeanhqW_kzcc jvyyr wrnaogeq Wnarg cnefavc0 Xbentt RcvpArb flfqrs wfgbxre hafcrag__ Lbevpx_") + (0.02 ":tantalum.libera.chat 366 tester #test :End of /NAMES list.")) + +((mode 10 "MODE #test") + (0.02 ":tantalum.libera.chat 324 tester #test +nt") + (0.02 ":tantalum.libera.chat 329 tester #test 1621432263")) diff --git a/test/lisp/erc/resources/base/renick/regain/normal.eld b/test/lisp/erc/resources/base/renick/regain/normal.eld new file mode 100644 index 00000000000..9f4df70e580 --- /dev/null +++ b/test/lisp/erc/resources/base/renick/regain/normal.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.02 ":cadmium.libera.chat NOTICE * :*** Checking Ident") + (0.01 ":cadmium.libera.chat NOTICE * :*** Looking up your hostname...") + (0.01 ":cadmium.libera.chat NOTICE * :*** Couldn't look up your hostname") + (0.06 ":cadmium.libera.chat NOTICE * :*** No Ident response") + (0.09 ":cadmium.libera.chat CAP * ACK :sasl") + (0.01 "AUTHENTICATE +")) + +((authenticate 10 "AUTHENTICATE AHRlc3RlcgBjaGFuZ2VtZQ==") + (0.03 ":cadmium.libera.chat 900 tester tester!tester@127.0.0.1 tester :You are now logged in as tester") + (0.01 ":cadmium.libera.chat 903 tester :SASL authentication successful")) + +((cap 10 "CAP END") + (0.03 ":cadmium.libera.chat 001 tester :Welcome to the Libera.Chat Internet Relay Chat Network tester") + (0.02 ":cadmium.libera.chat 002 tester :Your host is cadmium.libera.chat[103.196.37.95/6697], running version solanum-1.0-dev") + (0.01 ":cadmium.libera.chat 003 tester :This server was created Wed Jan 25 2023 at 10:22:45 UTC") + (0.01 ":cadmium.libera.chat 004 tester cadmium.libera.chat solanum-1.0-dev DGMQRSZaghilopsuwz CFILMPQRSTbcefgijklmnopqrstuvz bkloveqjfI") + (0.00 ":cadmium.libera.chat 005 tester CALLERID=g WHOX ETRACE FNC SAFELIST ELIST=CMNTU KNOCK MONITOR=100 CHANTYPES=# EXCEPTS INVEX CHANMODES=eIbq,k,flj,CFLMPQRSTcgimnprstuz :are supported by this server") + (0.01 ":cadmium.libera.chat 005 tester CHANLIMIT=#:250 PREFIX=(ov)@+ MAXLIST=bqeI:100 MODES=4 NETWORK=Libera.Chat STATUSMSG=@+ CASEMAPPING=rfc1459 NICKLEN=16 MAXNICKLEN=16 CHANNELLEN=50 TOPICLEN=390 DEAF=D :are supported by this server") + (0.01 ":cadmium.libera.chat 005 tester TARGMAX=NAMES:1,LIST:1,KICK:1,WHOIS:1,PRIVMSG:4,NOTICE:4,ACCEPT:,MONITOR: EXTBAN=$,ajrxz :are supported by this server") + (0.01 ":cadmium.libera.chat 251 tester :There are 70 users and 42996 invisible on 28 servers") + (0.02 ":cadmium.libera.chat 252 tester 38 :IRC Operators online") + (0.01 ":cadmium.libera.chat 253 tester 57 :unknown connection(s)") + (0.01 ":cadmium.libera.chat 254 tester 22912 :channels formed") + (0.01 ":cadmium.libera.chat 255 tester :I have 2499 clients and 1 servers") + (0.01 ":cadmium.libera.chat 265 tester 2499 4187 :Current local users 2499, max 4187") + (0.01 ":cadmium.libera.chat 266 tester 43066 51827 :Current global users 43066, max 51827") + (0.01 ":cadmium.libera.chat 250 tester :Highest connection count: 4188 (4187 clients) (319420 connections received)") + (0.01 ":cadmium.libera.chat 375 tester :- cadmium.libera.chat Message of the Day - ") + (0.01 ":cadmium.libera.chat 372 tester :- This server kindly provided by Mach Dilemma (www.m-d.net)") + (0.01 ":cadmium.libera.chat 372 tester :- Welcome to Libera Chat, the IRC network for") + (0.00 ":cadmium.libera.chat 372 tester :- Email: support@libera.chat") + (0.00 ":cadmium.libera.chat 376 tester :End of /MOTD command.") + (0.00 ":tester MODE tester :+Ziw") + (0.02 ":SaslServ!SaslServ@services.libera.chat NOTICE tester :Last login from: \2~tester@127.0.0.1\2 on Apr 07 01:02:11 2023 +0000.")) + +((mode 10 "MODE tester +i")) + +((join 10 "JOIN #test") + (0.09 ":tester!~tester@127.0.0.1 JOIN #test")) + +((mode 10 "MODE #test") + (0.03 ":cadmium.libera.chat 353 tester = #test :tester zbyqbepbqre7 pusevgfpu Thrfg2187 zngbeb qnexNssvavgl wrebzr- rqpentt Ilehf grfg2 AvtugZbaxrl pevfgvvbna xrivap_ fnvybePng shohxv gxan arrqyr avpx16 NeanhqW_kzcc Lbevpx_ hafcrag__ wfgbxre flfqrs RcvpArb Xbentt jvyyr cnefavc0 Wnarg wrnaogeq") + (0.02 ":cadmium.libera.chat 366 tester #test :End of /NAMES list.") + (0.00 ":cadmium.libera.chat 324 tester #test +nt") + (0.01 ":cadmium.libera.chat 329 tester #test 1621432263")) + +((drop 0 DROP)) commit 03eddc99242bb430a82f468251ed76602d457702 Author: F. Jason Park Date: Wed Mar 8 06:14:36 2023 -0800 Add probing erc-server-reconnect-function variant * lisp/erc/erc-backend.el (erc-server-reconnect-timeout): Replace questionable claim with recommendation for alternate value when experiencing nick rejections. (erc-server-reconnect-function): Add new, somewhat experimental value `erc-server-delayed-check-reconnect'. (erc--server-connect-function): Add variable for process-dialing monitor, a function. (erc--server-propagate-failed-connection): Add function to serve as default monitor to run on process creation and maybe execute failure handlers. (erc-server-connect): Run `erc--server-connect-function' for async processes one second after creation. (erc--server-reconnect-timeout, erc--server-reconnect-timeout-check, erc--server-reconnect-timeout-scale-function, erc--server-reconnect-timeout-double): Add supporting variables and functions for `erc-server-delayed-check-reconnect'. (erc-server-delayed-check-reconnect): Add possible alternate value for option `erc-server-reconnect-function' that only attempts to reconnect after hearing back from the server. (erc-schedule-reconnect): Ensure previous `erc-server-process' is deleted. * test/lisp/erc/erc-scenarios-base-auto-recon.el: New file. * test/lisp/erc/resources/base/reconnect/just-eof.eld: New file. * test/lisp/erc/resources/base/reconnect/just-ping.eld: New file. * test/lisp/erc/resources/base/reconnect/ping-pong.eld: New file. * test/lisp/erc/resources/base/reconnect/unexpected-disconnect.eld: New file. * test/lisp/erc/resources/erc-scenarios-common.el (erc-scenarios-common--make-bindings): Shadow `timer-list'. (Bug#62044.) diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index bf3c2b5b308..acfbe3ef3a6 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -415,8 +415,10 @@ erc-server-reconnect-attempts (defcustom erc-server-reconnect-timeout 1 "Number of seconds to wait between successive reconnect attempts. - -If a key is pressed while ERC is waiting, it will stop waiting." +If this value is too low, servers may reject your initial nick +request upon reconnecting because they haven't yet noticed that +your previous connection is dead. If this happens, try setting +this value to 120 or greater." :type 'number) (defcustom erc-server-reconnect-function 'erc-server-delayed-reconnect @@ -427,6 +429,7 @@ erc-server-reconnect-function and optionally alter the attempts tally." :package-version '(ERC . "5.5") :type '(choice (function-item erc-server-delayed-reconnect) + (function-item erc-server-delayed-check-reconnect) function)) (defcustom erc-split-line-length 440 @@ -658,6 +661,30 @@ erc--register-connection (run-hooks 'erc--server-post-connect-hook) (erc-login)) +(defvar erc--server-connect-function #'erc--server-propagate-failed-connection + "Function called one second after creating a server process. +Called with the newly created process just before the opening IRC +protocol exchange.") + +(defun erc--server-propagate-failed-connection (process) + "Ensure the PROCESS sentinel runs at least once on early failure. +Act as a watchdog timer to force `erc-process-sentinel' and its +finalizers, like `erc-disconnected-hook', to run when PROCESS has +a status of `failed' after one second. But only do so when its +error data is something ERC recognizes. Print an explanation to +the server buffer in any case." + (when (eq (process-status process) 'failed) + (erc-display-message + nil 'error (process-buffer process) + (format "Process exit status: %S" (process-exit-status process))) + (pcase (process-exit-status process) + (111 + (erc-process-sentinel process "failed with code 111\n")) + (`(file-error . ,_) + (erc-process-sentinel process "failed with code -523\n")) + ((rx "tls" (+ nonl) "failed") + (erc-process-sentinel process "failed with code -525\n"))))) + (defvar erc--server-connect-dumb-ipv6-regexp ;; Not for validation (gives false positives). (rx bot "[" (group (+ (any xdigit digit ":.")) (? "%" (+ alnum))) "]" eot)) @@ -710,7 +737,9 @@ erc-server-connect ;; MOTD line) (if (eq (process-status process) 'connect) ;; waiting for a non-blocking connect - keep the user informed - (erc-display-message nil nil buffer "Opening connection..\n") + (progn + (erc-display-message nil nil buffer "Opening connection..\n") + (run-at-time 1 nil erc--server-connect-function process)) (message "%s...done" msg) (erc--register-connection)))) @@ -744,6 +773,78 @@ erc-server-delayed-reconnect (with-current-buffer buffer (erc-server-reconnect)))) +(defvar-local erc--server-reconnect-timeout nil) +(defvar-local erc--server-reconnect-timeout-check 10) +(defvar-local erc--server-reconnect-timeout-scale-function + #'erc--server-reconnect-timeout-double) + +(defun erc--server-reconnect-timeout-double (existing) + "Double EXISTING timeout, but cap it at 5 minutes." + (min 300 (* existing 2))) + +;; This may appear to hang at various places. It's assumed that when +;; *Messages* contains "Waiting for socket ..." or similar, progress +;; will be made eventually. + +(defun erc-server-delayed-check-reconnect (buffer) + "Wait for internet connectivity before trying to reconnect. +Expect BUFFER to be the server buffer for the current connection." + (when (buffer-live-p buffer) + (with-current-buffer buffer + (setq erc--server-reconnect-timeout + (funcall erc--server-reconnect-timeout-scale-function + (or erc--server-reconnect-timeout + erc-server-reconnect-timeout))) + (let* ((reschedule (lambda (proc) + (when (buffer-live-p buffer) + (with-current-buffer buffer + (let ((erc-server-reconnect-timeout + erc--server-reconnect-timeout)) + (delete-process proc) + (erc-display-message nil 'error buffer + "Nobody home...") + (erc-schedule-reconnect buffer 0)))))) + (conchk-exp (time-add erc--server-reconnect-timeout-check + (current-time))) + (conchk-timer nil) + (conchk (lambda (proc) + (let ((status (process-status proc)) + (xprdp (time-less-p conchk-exp (current-time)))) + (when (or (not (eq 'connect status)) xprdp) + (cancel-timer conchk-timer)) + (when (buffer-live-p buffer) + (cond (xprdp (erc-display-message + nil 'error buffer + "Timed out while dialing...") + (delete-process proc) + (funcall reschedule proc)) + ((eq 'failed status) + (funcall reschedule proc))))))) + (sentinel (lambda (proc event) + (pcase event + ("open\n" + (run-at-time nil nil #'send-string proc + (format "PING %d\r\n" + (time-convert nil 'integer)))) + ((or "connection broken by remote peer\n" + (rx bot "failed")) + (funcall reschedule proc))))) + (filter (lambda (proc _) + (delete-process proc) + (with-current-buffer buffer + (setq erc--server-reconnect-timeout nil)) + (run-at-time nil nil #'erc-server-delayed-reconnect + buffer)))) + (condition-case _ + (let ((proc (funcall erc-session-connector + "*erc-connectivity-check*" nil + erc-session-server erc-session-port + :nowait t))) + (setq conchk-timer (run-at-time 1 1 conchk proc)) + (set-process-filter proc filter) + (set-process-sentinel proc sentinel)) + (file-error (funcall reschedule nil))))))) + (defun erc-server-filter-function (process string) "The process filter for the ERC server." (with-current-buffer (process-buffer process) @@ -823,11 +924,16 @@ erc-schedule-reconnect `erc-server-reconnect-count' by INCR unconditionally." (let ((count (and (integerp erc-server-reconnect-attempts) (- erc-server-reconnect-attempts - (cl-incf erc-server-reconnect-count (or incr 1)))))) - (erc-display-message nil 'error (current-buffer) 'reconnecting + (cl-incf erc-server-reconnect-count (or incr 1))))) + (proc (buffer-local-value 'erc-server-process buffer))) + (erc-display-message nil 'error buffer 'reconnecting ?m erc-server-reconnect-timeout ?i (if count erc-server-reconnect-count "N") ?n (if count erc-server-reconnect-attempts "A")) + (set-process-sentinel proc #'ignore) + (set-process-filter proc nil) + (delete-process proc) + (erc-update-mode-line) (setq erc-server-reconnecting nil erc--server-reconnect-timer (run-at-time erc-server-reconnect-timeout nil diff --git a/test/lisp/erc/erc-scenarios-base-auto-recon.el b/test/lisp/erc/erc-scenarios-base-auto-recon.el new file mode 100644 index 00000000000..40e2c23408b --- /dev/null +++ b/test/lisp/erc/erc-scenarios-base-auto-recon.el @@ -0,0 +1,141 @@ +;;; erc-scenarios-base-auto-recon.el --- auto-recon scenarios -*- lexical-binding: t -*- + +;; Copyright (C) 2023 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 . + +;;; Code: + +(require 'ert-x) +(eval-and-compile + (let ((load-path (cons (ert-resource-directory) load-path))) + (require 'erc-scenarios-common))) + +(defun erc-scenarios-base-auto-recon--get-unused-port () + (let ((server (make-network-process :name "*erc-scenarios-base-auto-recon*" + :host "localhost" + :service t + :server t))) + (delete-process server) + (process-contact server :service))) + +;; This demos one possible flavor of intermittent service. +;; It may end up needing to be marked :unstable. + +(ert-deftest erc-scenarios-base-auto-recon-unavailable () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-server-flood-penalty 0.1) + (port (erc-scenarios-base-auto-recon--get-unused-port)) + (erc--server-reconnect-timeout-scale-function (lambda (_) 1)) + (erc-server-auto-reconnect t) + (erc-server-reconnect-function #'erc-server-delayed-check-reconnect) + (expect (erc-d-t-make-expecter)) + (erc-scenarios-common-dialog "base/reconnect") + (dumb-server nil)) + + (ert-info ("Dialing fails: nobody home") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :full-name "tester") + (erc-d-t-wait-for 10 (not (erc-server-process-alive))) + (erc-d-t-wait-for 10 erc--server-reconnect-timer) + (funcall expect 10 "Opening connection") + (funcall expect 10 "failed") + + (ert-info ("Reconnect function freezes attempts at 1") + (funcall expect 10 '(: "reconnecting" (+ nonl) "attempt 1/2")) + (funcall expect 10 "nobody home") + (funcall expect 10 '(: "reconnecting" (+ nonl) "attempt 1/2")) + (funcall expect 10 "nobody home")))) + + (ert-info ("Service appears") + (setq dumb-server (erc-d-run "localhost" port + 'just-eof 'unexpected-disconnect)) + (with-current-buffer (format "127.0.0.1:%d" port) + (funcall expect 10 "server is in debug mode") + (should (equal (buffer-name) "FooNet")))) + + (ert-info ("Service interrupted, reconnect starts again") + (with-current-buffer "FooNet" + (funcall expect 10 "failed") + (funcall expect 10 '(: "reconnecting" (+ nonl) "attempt 1/2")))) + + (ert-info ("Service restored") + (delete-process dumb-server) + (setq dumb-server (erc-d-run "localhost" port + 'just-eof 'unexpected-disconnect)) + (with-current-buffer "FooNet" + (funcall expect 10 "server is in debug mode"))) + + (ert-info ("Service interrupted a third time, reconnect starts yet again") + (with-current-buffer "FooNet" + (funcall expect 10 "failed") + (funcall expect 10 '(: "reconnecting" (+ nonl) "attempt 1/2")) + (erc-cmd-RECONNECT "cancel") + (funcall expect 10 "canceled"))))) + +;; In this test, a listener accepts but doesn't respond to any messages. + +(ert-deftest erc-scenarios-base-auto-recon-no-proto () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-server-flood-penalty 0.1) + (erc-scenarios-common-dialog "base/reconnect") + (erc-d-auto-pong nil) + (dumb-server (erc-d-run "localhost" t 'unexpected-disconnect)) + (port (process-contact dumb-server :service)) + (erc--server-reconnect-timeout-scale-function (lambda (_) 1)) + (erc--server-reconnect-timeout-check 0.5) + (erc-server-auto-reconnect t) + (erc-server-reconnect-function #'erc-server-delayed-check-reconnect) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Session succeeds but cut short") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :full-name "tester") + (funcall expect 10 "server is in debug mode") + (should (equal (buffer-name) "FooNet")) + (erc-d-t-wait-for 10 erc--server-reconnect-timer) + (delete-process dumb-server) + (funcall expect 10 "failed") + + (ert-info ("Reconnect function freezes attempts at 1") + (funcall expect 10 '(: "reconnecting" (+ nonl) "attempt 1/2")) + (funcall expect 10 "nobody home") + (funcall expect 10 "timed out while dialing") + (funcall expect 10 '(: "reconnecting" (+ nonl) "attempt 1/2")) + (funcall expect 10 "nobody home")))) + + (ert-info ("Service restored") + (setq dumb-server (erc-d-run "localhost" port + 'just-ping + 'ping-pong + 'unexpected-disconnect)) + (with-current-buffer "FooNet" + (funcall expect 30 "server is in debug mode"))) + + (ert-info ("Service interrupted again, reconnect starts again") + (with-current-buffer "FooNet" + (funcall expect 10 "failed") + (funcall expect 10 '(: "reconnecting" (+ nonl) "attempt 1/2")) + (erc-cmd-RECONNECT "cancel") + (funcall expect 10 "canceled"))))) + +;;; erc-scenarios-base-auto-recon.el ends here diff --git a/test/lisp/erc/resources/base/reconnect/just-eof.eld b/test/lisp/erc/resources/base/reconnect/just-eof.eld new file mode 100644 index 00000000000..c80a39b3170 --- /dev/null +++ b/test/lisp/erc/resources/base/reconnect/just-eof.eld @@ -0,0 +1,3 @@ +;; -*- mode: lisp-data; -*- +((eof 5 EOF)) +((drop 0 DROP)) diff --git a/test/lisp/erc/resources/base/reconnect/just-ping.eld b/test/lisp/erc/resources/base/reconnect/just-ping.eld new file mode 100644 index 00000000000..d57888b42d3 --- /dev/null +++ b/test/lisp/erc/resources/base/reconnect/just-ping.eld @@ -0,0 +1,4 @@ +;; -*- mode: lisp-data; -*- +((ping 20 "PING")) + +((eof 10 EOF)) diff --git a/test/lisp/erc/resources/base/reconnect/ping-pong.eld b/test/lisp/erc/resources/base/reconnect/ping-pong.eld new file mode 100644 index 00000000000..b3d36cf6cec --- /dev/null +++ b/test/lisp/erc/resources/base/reconnect/ping-pong.eld @@ -0,0 +1,6 @@ +;; -*- mode: lisp-data; -*- +((ping 10 "PING ") + (0 "PONG fake")) + +((eof 10 EOF)) +((drop 0 DROP)) diff --git a/test/lisp/erc/resources/base/reconnect/unexpected-disconnect.eld b/test/lisp/erc/resources/base/reconnect/unexpected-disconnect.eld new file mode 100644 index 00000000000..386d0f4b085 --- /dev/null +++ b/test/lisp/erc/resources/base/reconnect/unexpected-disconnect.eld @@ -0,0 +1,24 @@ +;; -*- mode: lisp-data; -*- +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") + (0 ":irc.foonet.org 001 tester :Welcome to the foonet IRC Network tester") + (0 ":irc.foonet.org 002 tester :Your host is irc.foonet.org, running version oragono-2.6.0-7481bf0385b95b16") + (0 ":irc.foonet.org 003 tester :This server was created Tue, 04 May 2021 05:06:18 UTC") + (0 ":irc.foonet.org 004 tester irc.foonet.org oragono-2.6.0-7481bf0385b95b16 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (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 ":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:1,WHOIS:1,USERHOST:10,PRIVMSG:4,TAGMSG:4,NOTICE:4,MONITOR:100 TOPICLEN=390 UTF8MAPPING=rfc8265 UTF8ONLY WHOX :are supported by this server") + (0 ":irc.foonet.org 005 tester draft/CHATHISTORY=100 :are supported by this server") + (0 ":irc.foonet.org 251 tester :There are 0 users and 3 invisible on 1 server(s)") + (0 ":irc.foonet.org 252 tester 0 :IRC Operators online") + (0 ":irc.foonet.org 253 tester 0 :unregistered connections") + (0 ":irc.foonet.org 254 tester 1 :channels formed") + (0 ":irc.foonet.org 255 tester :I have 3 clients and 0 servers") + (0 ":irc.foonet.org 265 tester 3 3 :Current local users 3, max 3") + (0 ":irc.foonet.org 266 tester 3 3 :Current global users 3, max 3") + (0 ":irc.foonet.org 422 tester :MOTD File is missing")) + +((mode-user 10 "MODE tester +i") + (0 ":irc.foonet.org 221 tester +i") + (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.")) + +((drop 0 DROP)) diff --git a/test/lisp/erc/resources/erc-scenarios-common.el b/test/lisp/erc/resources/erc-scenarios-common.el index 0d9a79ae9ce..f259c88594b 100644 --- a/test/lisp/erc/resources/erc-scenarios-common.el +++ b/test/lisp/erc/resources/erc-scenarios-common.el @@ -121,6 +121,7 @@ erc-scenarios-common--print-trace (erc-modules (copy-sequence erc-modules)) (inhibit-interaction t) (auth-source-do-cache nil) + (timer-list (copy-sequence timer-list)) (erc-auth-source-parameters-join-function nil) (erc-autojoin-channels-alist nil) (erc-server-auto-reconnect nil) commit 4da7d24988ae096d757021eb8ed9d014990de16e Author: F. Jason Park Date: Sat Mar 11 09:25:24 2023 -0800 Add MOTD command to ERC * lisp/erc/erc-backend.el (erc-server-402, erc-server-402-functions): Add new response handler and hook. * lisp/erc/erc.el (erc-cmd-MOTD): New function to shield erc-network from handling post-connection MOTD replies. Thanks to Emanuel Berg for reporting this (bug#62151). (erc-message-english-s402): Define new ERR_NOSUCHSERVER message template. * test/lisp/erc/erc-scenarios-base-misc-regressions.el: New file. * test/lisp/erc/resources/base/commands/motd.eld: New file. diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 567443f5329..bf3c2b5b308 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -2236,6 +2236,11 @@ erc-server-322-message (erc-display-message parsed '(notice error) 'active 's401 ?n nick/channel))) +(define-erc-response-handler (402) + "No such server." nil + (erc-display-message parsed '(notice error) 'active + 's402 ?c (cadr (erc-response.command-args parsed)))) + (define-erc-response-handler (403) "No such channel." nil (erc-display-message parsed '(notice error) 'active @@ -2383,7 +2388,7 @@ erc-server-322-message ;; (define-erc-response-handler (323 364 365 381 382 392 393 394 395 ;; 200 201 202 203 204 205 206 208 209 211 212 213 ;; 214 215 216 217 218 219 241 242 243 244 249 261 -;; 262 302 342 351 402 407 409 411 413 414 415 +;; 262 302 342 351 407 409 411 413 414 415 ;; 423 424 436 441 443 444 467 471 472 473 KILL) ;; nil nil ;; (ignore proc parsed)) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index f76c770f585..66bc4985027 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -4051,6 +4051,22 @@ erc-cmd-TIME (t (erc-server-send "TIME")))) (defalias 'erc-cmd-DATE #'erc-cmd-TIME) +(defun erc-cmd-MOTD (&optional target) + "Ask server to send the current MOTD. +Some IRCds simply ignore TARGET." + (letrec ((oneoff (lambda (proc parsed) + (with-current-buffer (erc-server-buffer) + (cl-assert (eq (current-buffer) (process-buffer proc))) + (remove-hook 'erc-server-402-functions h402 t) + (remove-hook 'erc-server-376-functions h376 t) + (remove-hook 'erc-server-422-functions h422 t)) + (erc-server-MOTD proc parsed) + t)) + (h402 (erc-once-with-server-event 402 oneoff)) + (h376 (erc-once-with-server-event 376 oneoff)) + (h422 (erc-once-with-server-event 422 oneoff))) + (erc-server-send (concat "MOTD" (and target " ") target)))) + (defun erc-cmd-TOPIC (topic) "Set or request the topic for a channel. LINE has the format: \"#CHANNEL TOPIC\", \"#CHANNEL\", \"TOPIC\" @@ -7136,6 +7152,7 @@ erc-define-catalog (s379 . "%c: Forwarded to %f") (s391 . "The time at %s is %t") (s401 . "%n: No such nick/channel") + (s402 . "%c: No such server") (s403 . "%c: No such channel") (s404 . "%c: Cannot send to channel") (s405 . "%c: You have joined too many channels") diff --git a/test/lisp/erc/erc-scenarios-base-misc-regressions.el b/test/lisp/erc/erc-scenarios-base-misc-regressions.el index 16b2cb355d1..c1915d088a0 100644 --- a/test/lisp/erc/erc-scenarios-base-misc-regressions.el +++ b/test/lisp/erc/erc-scenarios-base-misc-regressions.el @@ -124,4 +124,48 @@ erc-scenarios-base-channel-buffer-revival (with-current-buffer (erc-d-t-wait-for 5 (get-buffer "#chan")) (erc-d-t-search-for 10 "and be prosperous"))))) +;; This defends against a partial regression in which an /MOTD caused +;; 376 and 422 handlers in erc-networks to run. + +(ert-deftest erc-cmd-MOTD () + :tags '(:expensive-test) + (erc-scenarios-common-with-cleanup + ((erc-scenarios-common-dialog "base/commands") + (erc-server-flood-penalty 0.1) + (dumb-server (erc-d-run "localhost" t 'motd)) + (port (process-contact dumb-server :service)) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect to server") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "tester" + :full-name "tester") + (funcall expect 10 "This is the default Ergo MOTD") + (funcall expect 10 "debug mode"))) + + (ert-info ("Send plain MOTD") + (with-current-buffer "foonet" + (erc-cmd-MOTD) + (funcall expect -0.2 "Unexpected state detected") + (funcall expect 10 "This is the default Ergo MOTD"))) + + (ert-info ("Send MOTD with known target") + (with-current-buffer "foonet" + (erc-scenarios-common-say "/MOTD irc1.foonet.org") + (funcall expect -0.2 "Unexpected state detected") + (funcall expect 10 "This is the default Ergo MOTD"))) + + (ert-info ("Send MOTD with erroneous target") + (with-current-buffer "foonet" + (erc-scenarios-common-say "/MOTD fake.foonet.org") + (funcall expect -0.2 "Unexpected state detected") + (funcall expect 10 "No such server") + ;; Message may show up before the handler runs. + (erc-d-t-wait-for 10 + (not (local-variable-p 'erc-server-402-functions))) + (should-not (local-variable-p 'erc-server-376-functions)) + (should-not (local-variable-p 'erc-server-422-functions)) + (erc-cmd-QUIT ""))))) + ;;; erc-scenarios-base-misc-regressions.el ends here diff --git a/test/lisp/erc/resources/base/commands/motd.eld b/test/lisp/erc/resources/base/commands/motd.eld new file mode 100644 index 00000000000..6d10ee122e2 --- /dev/null +++ b/test/lisp/erc/resources/base/commands/motd.eld @@ -0,0 +1,48 @@ +;; -*- mode: lisp-data; -*- +((nick 10 "NICK tester")) +((user 10 "USER user 0 * :tester") + (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.11.1") + (0.01 ":irc.foonet.org 003 tester :This server was created Sun, 12 Mar 2023 02:30:29 UTC") + (0.00 ":irc.foonet.org 004 tester irc.foonet.org ergo-v2.11.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0.00 ":irc.foonet.org 005 tester AWAYLEN=390 BOT=B CASEMAPPING=ascii CHANLIMIT=#:100 CHANMODES=Ibe,k,fl,CEMRUimnstu CHANNELLEN=64 CHANTYPES=# CHATHISTORY=1000 ELIST=U EXCEPTS EXTBAN=,m FORWARD=f INVEX :are supported by this server") + (0.01 ":irc.foonet.org 005 tester KICKLEN=390 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 UTF8ONLY WHOX :are supported by this server") + (0.01 ":irc.foonet.org 005 tester draft/CHATHISTORY=1000 :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.00 ":irc.foonet.org 375 tester :- irc.foonet.org Message of the day - ") + (0.00 ":irc.foonet.org 372 tester :- This is the default Ergo MOTD.") + (0.01 ":irc.foonet.org 372 tester :- ") + (0.02 ":irc.foonet.org 372 tester :- For more information on using these, see MOTDFORMATTING.md") + (0.00 ":irc.foonet.org 376 tester :End of MOTD command")) + +((mode 10 "MODE tester +i") + (0.00 ":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.") + (0.05 ":irc.foonet.org 221 tester +i")) + +((motd-1 10 "MOTD") + (0.08 ":irc.foonet.org 375 tester :- irc.foonet.org Message of the day - ") + (0.02 ":irc.foonet.org 372 tester :- This is the default Ergo MOTD.") + (0.01 ":irc.foonet.org 372 tester :- ") + (0.00 ":irc.foonet.org 372 tester :- For more information on using these, see MOTDFORMATTING.md") + (0.00 ":irc.foonet.org 376 tester :End of MOTD command")) + +((motd-2 10 "MOTD irc1.foonet.org") + (0.08 ":irc1.foonet.org 375 tester :- irc1.foonet.org Message of the day - ") + (0.02 ":irc1.foonet.org 372 tester :- This is the default Ergo MOTD.") + (0.01 ":irc1.foonet.org 372 tester :- ") + (0.00 ":irc1.foonet.org 372 tester :- For more information on using these, see MOTDFORMATTING.md") + (0.00 ":irc1.foonet.org 376 tester :End of MOTD command")) + +((motd-3 10 "MOTD fake.foonet.org") + (0.00 ":irc.foonet.org 402 tester fake.foonet.org :No such server")) + +((quit 10 "QUIT :\2ERC\2") + (0.07 ":tester!~u@h3f95zveyc38a.irc QUIT :Quit: \2ERC\2 5.5 (IRC client for GNU Emacs 30.0.50)") + (0.01 "ERROR :Quit: \2ERC\2 5.5 (IRC client for GNU Emacs 30.0.50)")) commit 61ed0b43cdb3cc83af0d3429c482c2b329e1b415 Author: F. Jason Park Date: Fri Mar 24 00:16:56 2023 -0700 Split overlong outgoing messages in erc-sasl * lisp/erc/erc-sasl.el: (erc-server-AUTHENTICATE): Account for client messages exceeding 400 bytes. (Bug#62421.) * test/lisp/erc/erc-scenarios-sasl.el (erc-scenarios-sasl--plain-overlong-split, erc-scenarios-sasl--plain-overlong-aligned): Add tests. * test/lisp/erc/resources/sasl/plain-overlong-aligned.eld: New file. * test/lisp/erc/resources/sasl/plain-overlong-split.eld: New file. diff --git a/lisp/erc/erc-sasl.el b/lisp/erc/erc-sasl.el index 9265691c2d7..bfe17285a68 100644 --- a/lisp/erc/erc-sasl.el +++ b/lisp/erc/erc-sasl.el @@ -369,9 +369,12 @@ sasl data (sasl-step-data step)) (when (string= data "") (setq data nil)) - (when data - (setq data (erc--unfun (base64-encode-string data t)))) - (erc-server-send (concat "AUTHENTICATE " (or data "+")))))) + (setq data (if data (erc--unfun (base64-encode-string data t)) "+")) + (while (not (string-empty-p data)) + (let ((end (min 400 (length data)))) + ;; For now, assume this is unlikely to block + (erc-server-send (concat "AUTHENTICATE " (substring data 0 end))) + (setq data (concat (substring data end) (and (= end 400) "+")))))))) (defun erc-sasl--destroy (proc) (run-hook-with-args 'erc-quit-hook proc) diff --git a/test/lisp/erc/erc-scenarios-sasl.el b/test/lisp/erc/erc-scenarios-sasl.el index 3878237c7d2..ab652d72dd2 100644 --- a/test/lisp/erc/erc-scenarios-sasl.el +++ b/test/lisp/erc/erc-scenarios-sasl.el @@ -51,6 +51,70 @@ erc-scenarios-sasl--plain ;; Regression "\0\0\0\0 ..." caused by (fillarray passphrase 0) (should (string= erc-sasl-password "password123")))))) +;; The user's unreasonably long password is apportioned into chunks on +;; the way out the door. + +(ert-deftest erc-scenarios-sasl--plain-overlong-split () + :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-overlong-split)) + (port (process-contact dumb-server :service)) + (erc-modules (cons 'sasl erc-modules)) + (erc-sasl-password + (concat + "Est ut beatae omnis ipsam. " + "Quis fugiat deleniti totam qui. " + "Ipsum quam a dolorum tempora velit laborum odit. " + "Et saepe voluptate sed cumque vel. " + "Voluptas sint ab pariatur libero veritatis corrupti. " + "Vero iure omnis ullam. " + "Vero beatae dolores facere fugiat ipsam. " + "Ea est pariatur minima nobis sunt aut ut. " + "Dolores ut laudantium maiores temporibus voluptates. " + "Reiciendis impedit omnis et unde delectus quas ab. " + "Quae eligendi necessitatibus doloribus " + "molestias tempora magnam assumenda.")) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "emersion" + :user "emersion" + :full-name "emersion") + (funcall expect 10 "This server is in debug mode") + (erc-cmd-QUIT ""))))) + +(ert-deftest erc-scenarios-sasl--plain-overlong-aligned () + :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-overlong-aligned)) + (port (process-contact dumb-server :service)) + (erc-modules (cons 'sasl erc-modules)) + (erc-sasl-password + (concat + "Est ut beatae omnis ipsam. " + "Quis fugiat deleniti totam qui. " + "Ipsum quam a dolorum tempora velit laborum odit. " + "Et saepe voluptate sed cumque vel. " + "Voluptas sint ab pariatur libero veritatis corrupti. " + "Vero iure omnis ullam. Vero beatae dolores facere fugiat ipsam. " + "Ea est pariatur minima nobis")) + (expect (erc-d-t-make-expecter))) + + (ert-info ("Connect") + (with-current-buffer (erc :server "127.0.0.1" + :port port + :nick "emersion" + :user "emersion" + :full-name "emersion") + (funcall expect 10 "This server is in debug mode") + (erc-cmd-QUIT ""))))) + (ert-deftest erc-scenarios-sasl--external () :tags '(:expensive-test) (erc-scenarios-common-with-cleanup diff --git a/test/lisp/erc/resources/sasl/plain-overlong-aligned.eld b/test/lisp/erc/resources/sasl/plain-overlong-aligned.eld new file mode 100644 index 00000000000..6ed8981be0f --- /dev/null +++ b/test/lisp/erc/resources/sasl/plain-overlong-aligned.eld @@ -0,0 +1,39 @@ +;; -*- mode: lisp-data; -*- +((cap-req 10 "CAP REQ :sasl")) +((nick 10 "NICK emersion")) +((user 10 "USER emersion 0 * :emersion") + (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 10 "AUTHENTICATE PLAIN") + (0.0 ":irc.example.org AUTHENTICATE +")) +((authenticate-gimme-1 10 "AUTHENTICATE AGVtZXJzaW9uAEVzdCB1dCBiZWF0YWUgb21uaXMgaXBzYW0uIFF1aXMgZnVnaWF0IGRlbGVuaXRpIHRvdGFtIHF1aS4gSXBzdW0gcXVhbSBhIGRvbG9ydW0gdGVtcG9yYSB2ZWxpdCBsYWJvcnVtIG9kaXQuIEV0IHNhZXBlIHZvbHVwdGF0ZSBzZWQgY3VtcXVlIHZlbC4gVm9sdXB0YXMgc2ludCBhYiBwYXJpYXR1ciBsaWJlcm8gdmVyaXRhdGlzIGNvcnJ1cHRpLiBWZXJvIGl1cmUgb21uaXMgdWxsYW0uIFZlcm8gYmVhdGFlIGRvbG9yZXMgZmFjZXJlIGZ1Z2lhdCBpcHNhbS4gRWEgZXN0IHBhcmlhdHVyIG1pbmltYSBub2Jpcw==")) +((authenticate-gimme-2 10 "AUTHENTICATE +") + (0.0 ":irc.example.org 900 * * emersion :You are now logged in as emersion") + (0.0 ":irc.example.org 903 * :Authentication successful")) + +((cap-end 10 "CAP END") + (0.0 ":irc.example.org 001 emersion :Welcome to the ExampleOrg IRC Network emersion") + (0.0 ":irc.example.org 002 emersion :Your host is irc.example.org, running version oragono-2.6.1") + (0.0 ":irc.example.org 003 emersion :This server was created Sat, 17 Jul 2021 09:06:42 UTC") + (0.0 ":irc.example.org 004 emersion irc.example.org oragono-2.6.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0.0 ":irc.example.org 005 emersion 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.0 ":irc.example.org 005 emersion 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.0 ":irc.example.org 005 emersion draft/CHATHISTORY=100 :are supported by this server") + (0.0 ":irc.example.org 251 emersion :There are 1 users and 0 invisible on 1 server(s)") + (0.0 ":irc.example.org 252 emersion 0 :IRC Operators online") + (0.0 ":irc.example.org 253 emersion 0 :unregistered connections") + (0.0 ":irc.example.org 254 emersion 0 :channels formed") + (0.0 ":irc.example.org 255 emersion :I have 1 clients and 0 servers") + (0.0 ":irc.example.org 265 emersion 1 1 :Current local users 1, max 1") + (0.0 ":irc.example.org 266 emersion 1 1 :Current global users 1, max 1") + (0.0 ":irc.example.org 422 emersion :MOTD File is missing")) + +((mode-user 10 "MODE emersion +i") + (0.0 ":irc.example.org 221 emersion +Zi") + (0.0 ":irc.example.org NOTICE emersion :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 ":emersion!~u@yuvqisyu7m7qs.irc QUIT :Quit")) +((drop 1 DROP)) diff --git a/test/lisp/erc/resources/sasl/plain-overlong-split.eld b/test/lisp/erc/resources/sasl/plain-overlong-split.eld new file mode 100644 index 00000000000..3e6870790f3 --- /dev/null +++ b/test/lisp/erc/resources/sasl/plain-overlong-split.eld @@ -0,0 +1,39 @@ +;; -*- mode: lisp-data; -*- +((cap-req 10 "CAP REQ :sasl")) +((nick 10 "NICK emersion")) +((user 10 "USER emersion 0 * :emersion") + (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 10 "AUTHENTICATE PLAIN") + (0.0 ":irc.example.org AUTHENTICATE +")) +((authenticate-gimme-1 10 "AUTHENTICATE AGVtZXJzaW9uAEVzdCB1dCBiZWF0YWUgb21uaXMgaXBzYW0uIFF1aXMgZnVnaWF0IGRlbGVuaXRpIHRvdGFtIHF1aS4gSXBzdW0gcXVhbSBhIGRvbG9ydW0gdGVtcG9yYSB2ZWxpdCBsYWJvcnVtIG9kaXQuIEV0IHNhZXBlIHZvbHVwdGF0ZSBzZWQgY3VtcXVlIHZlbC4gVm9sdXB0YXMgc2ludCBhYiBwYXJpYXR1ciBsaWJlcm8gdmVyaXRhdGlzIGNvcnJ1cHRpLiBWZXJvIGl1cmUgb21uaXMgdWxsYW0uIFZlcm8gYmVhdGFlIGRvbG9yZXMgZmFjZXJlIGZ1Z2lhdCBpcHNhbS4gRWEgZXN0IHBhcmlhdHVyIG1pbmltYSBub2JpcyBz")) +((authenticate-gimme-2 10 "AUTHENTICATE dW50IGF1dCB1dC4gRG9sb3JlcyB1dCBsYXVkYW50aXVtIG1haW9yZXMgdGVtcG9yaWJ1cyB2b2x1cHRhdGVzLiBSZWljaWVuZGlzIGltcGVkaXQgb21uaXMgZXQgdW5kZSBkZWxlY3R1cyBxdWFzIGFiLiBRdWFlIGVsaWdlbmRpIG5lY2Vzc2l0YXRpYnVzIGRvbG9yaWJ1cyBtb2xlc3RpYXMgdGVtcG9yYSBtYWduYW0gYXNzdW1lbmRhLg==") + (0.0 ":irc.example.org 900 * * emersion :You are now logged in as emersion") + (0.0 ":irc.example.org 903 * :Authentication successful")) + +((cap-end 10 "CAP END") + (0.0 ":irc.example.org 001 emersion :Welcome to the ExampleOrg IRC Network emersion") + (0.0 ":irc.example.org 002 emersion :Your host is irc.example.org, running version oragono-2.6.1") + (0.0 ":irc.example.org 003 emersion :This server was created Sat, 17 Jul 2021 09:06:42 UTC") + (0.0 ":irc.example.org 004 emersion irc.example.org oragono-2.6.1 BERTZios CEIMRUabefhiklmnoqstuv Iabefhkloqv") + (0.0 ":irc.example.org 005 emersion 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.0 ":irc.example.org 005 emersion 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.0 ":irc.example.org 005 emersion draft/CHATHISTORY=100 :are supported by this server") + (0.0 ":irc.example.org 251 emersion :There are 1 users and 0 invisible on 1 server(s)") + (0.0 ":irc.example.org 252 emersion 0 :IRC Operators online") + (0.0 ":irc.example.org 253 emersion 0 :unregistered connections") + (0.0 ":irc.example.org 254 emersion 0 :channels formed") + (0.0 ":irc.example.org 255 emersion :I have 1 clients and 0 servers") + (0.0 ":irc.example.org 265 emersion 1 1 :Current local users 1, max 1") + (0.0 ":irc.example.org 266 emersion 1 1 :Current global users 1, max 1") + (0.0 ":irc.example.org 422 emersion :MOTD File is missing")) + +((mode-user 10 "MODE emersion +i") + (0.0 ":irc.example.org 221 emersion +Zi") + (0.0 ":irc.example.org NOTICE emersion :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 ":emersion!~u@yuvqisyu7m7qs.irc QUIT :Quit")) +((drop 1 DROP)) commit cf83f9a0821d1eaf5b1688b1e8a991dd01d05ed6 Author: Daniel Pettersson Date: Sat Mar 25 16:25:48 2023 +0100 Fix DCC GET flag parsing in erc-dcc * lisp/erc/erc-dcc.el (erc-cmd-DCC): Tokenize raw input line but also accommodate legacy invocation. (pcomplete/erc-mode/DCC): Quote file names when suggesting. Account for double-hyphen "end-of-options"-like separator. (erc-dcc-do-GET-command): Simplify signature, subsuming NICK in variadic args, now ARGS instead of FILE, which changes the arity from (2 . many) to (1 . many). Explain usage in doc string. Honor an optional separator, "--", if present. (Bug#62444.) * test/lisp/erc/erc-dcc-tests.el (erc-dcc-do-GET-command): Call new parameterized helper with various flag/file combinations. (erc-dcc-tests--erc-dcc-do-GET-command): New fixture function. (pcomplete/erc-mode/DCC--get-quoted, pcomplete/erc-mode/DCC--get-sep): New tests. diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el index 70683a92ffc..2012bcadae1 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el @@ -43,7 +43,7 @@ ;; /dcc chat nick - Either accept pending chat offer from nick, or offer ;; DCC chat to nick ;; /dcc close type [nick] - Close DCC connection (SEND/GET/CHAT) with nick -;; /dcc get [-t][-s] nick [file] - Accept DCC offer from nick +;; /dcc get [-t][-s] nick [--] file - Accept DCC offer from nick ;; /dcc list - List all DCC offers/connections ;; /dcc send nick file - Offer DCC SEND to nick @@ -389,12 +389,18 @@ erc-dcc-get-default-directory :type '(choice (const :value nil :tag "Default directory") directory)) ;;;###autoload -(defun erc-cmd-DCC (cmd &rest args) +(defun erc-cmd-DCC (line &rest compat-args) "Parser for /dcc command. This figures out the dcc subcommand and calls the appropriate routine to handle it. The function dispatched should be named \"erc-dcc-do-FOO-command\", where FOO is one of CLOSE, GET, SEND, LIST, CHAT, etc." - (when cmd + (let (cmd args) + ;; Called as library function (i.e., not directly as /dcc) + (if compat-args + (setq cmd line + args compat-args) + (setq args (delete "" (erc-compat--split-string-shell-command line)) + cmd (pop args))) (let ((fn (intern-soft (concat "erc-dcc-do-" (upcase cmd) "-command")))) (if fn (apply fn erc-server-process args) @@ -438,15 +444,20 @@ pcomplete/erc-mode/DCC (eq (plist-get elt :type) 'GET)) erc-dcc-list))) ('send (pcomplete-erc-all-nicks)))) + (when (equal "get" (downcase (pcomplete-arg 'first 1))) + (pcomplete-opt "-")) (pcomplete-here (pcase (intern (downcase (pcomplete-arg 'first 1))) - ('get (mapcar (lambda (elt) (plist-get elt :file)) + ('get (mapcar (lambda (elt) + (combine-and-quote-strings (list (plist-get elt :file)))) (cl-remove-if-not (lambda (elt) (and (eq (plist-get elt :type) 'GET) (erc-nick-equal-p (erc-extract-nick (plist-get elt :nick)) - (pcomplete-arg 1)))) + (pcase (pcomplete-arg 1) + ("--" (pcomplete-arg 2)) + (v v))))) erc-dcc-list))) ('close (mapcar #'erc-dcc-nick (cl-remove-if-not @@ -512,16 +523,33 @@ erc-dcc-do-CLOSE-command ?n (erc-extract-nick (plist-get ret :nick)))))) t)) -(defun erc-dcc-do-GET-command (proc nick &rest file) - "Do a DCC GET command. NICK is the person who is sending the file. -FILE is the filename. If FILE is split into multiple arguments, -re-join the arguments, separated by a space. -PROC is the server process." - (let* ((args (seq-group-by (lambda (s) (eq ?- (aref s 0))) (cons nick file))) +(defun erc-dcc-do-GET-command (proc &rest args) + "Perform a DCC GET command. +Recognize input conforming to the following usage syntax: + + /DCC GET [-t|-s] nick [--] filename + + nick The person who is sending the file. + filename The filename to be downloaded. Can be split into multiple + arguments that are then joined by a space. + flags \"-t\" sets `:turbo' in `erc-dcc-list' + \"-s\" sets `:secure' in `erc-dcc-list' + \"--\" indicates end of options + All of which are optional. + +Expect PROC to be the server process and ARGS to contain +everything after the subcommand \"GET\" in the usage description +above." + ;; Despite the advertised syntax above, we currently respect flags + ;; in these positions: [flag] nick [flag] filename [flag] + (let* ((trailing (and-let* ((trailing (member "--" args))) + (setq args (butlast args (length trailing))) + (cdr trailing))) + (args (seq-group-by (lambda (s) (eq ?- (aref s 0))) args)) (flags (prog1 (cdr (assq t args)) - (setq args (cdr (assq nil args)) - nick (pop args) - file (and args (mapconcat #'identity args " "))))) + (setq args (nconc (cdr (assq nil args)) trailing)))) + (nick (pop args)) + (file (and args (mapconcat #'identity args " "))) (elt (erc-dcc-member :nick nick :type 'GET :file file)) (filename (or file (plist-get elt :file) "unknown"))) (if elt diff --git a/test/lisp/erc/erc-dcc-tests.el b/test/lisp/erc/erc-dcc-tests.el index bd8a9fc7951..fed86eff2c5 100644 --- a/test/lisp/erc/erc-dcc-tests.el +++ b/test/lisp/erc/erc-dcc-tests.el @@ -100,7 +100,7 @@ erc-dcc-handle-ctcp-send--base (ert-deftest erc-dcc-handle-ctcp-send--turbo () (erc-dcc-tests--dcc-handle-ctcp-send t)) -(ert-deftest erc-dcc-do-GET-command () +(defun erc-dcc-tests--erc-dcc-do-GET-command (file &optional sep) (with-temp-buffer (let* ((proc (start-process "fake" (current-buffer) "sleep" "10")) (elt (list :nick "tester!~tester@fake.irc" @@ -109,7 +109,7 @@ erc-dcc-do-GET-command :parent proc :ip "127.0.0.1" :port "9899" - :file "foo.bin" + :file file :size 1405135128)) (erc-dcc-list (list elt)) ;; @@ -124,7 +124,7 @@ erc-dcc-do-GET-command erc-server-current-nick "dummy") (set-process-query-on-exit-flag proc nil) (cl-letf (((symbol-function 'read-file-name) - (lambda (&rest _) "foo.bin")) + (lambda (&rest _) file)) ((symbol-function 'erc-dcc-get-file) (lambda (&rest r) (push r calls)))) (goto-char (point-max)) @@ -134,38 +134,44 @@ erc-dcc-do-GET-command (ert-info ("No turbo") (should-not (plist-member elt :turbo)) (goto-char erc-input-marker) - (insert "/dcc GET tester foo.bin") + (insert "/dcc GET tester " (or sep "") (prin1-to-string file)) (erc-send-current-line) (should-not (plist-member (car erc-dcc-list) :turbo)) - (should (equal (pop calls) (list elt "foo.bin" proc)))) + (should (equal (pop calls) (list elt file proc)))) (ert-info ("Arg turbo in pos 2") (should-not (plist-member elt :turbo)) (goto-char erc-input-marker) - (insert "/dcc GET -t tester foo.bin") + (insert "/dcc GET -t tester " (or sep "") (prin1-to-string file)) (erc-send-current-line) (should (eq t (plist-get (car erc-dcc-list) :turbo))) - (should (equal (pop calls) (list elt "foo.bin" proc)))) + (should (equal (pop calls) (list elt file proc)))) (ert-info ("Arg turbo in pos 4") (setq elt (plist-put elt :turbo nil) erc-dcc-list (list elt)) (goto-char erc-input-marker) - (insert "/dcc GET tester -t foo.bin") + (insert "/dcc GET tester -t " (or sep "") (prin1-to-string file)) (erc-send-current-line) (should (eq t (plist-get (car erc-dcc-list) :turbo))) - (should (equal (pop calls) (list elt "foo.bin" proc)))) + (should (equal (pop calls) (list elt file proc)))) (ert-info ("Arg turbo in pos 6") (setq elt (plist-put elt :turbo nil) erc-dcc-list (list elt)) (goto-char erc-input-marker) - (insert "/dcc GET tester foo.bin -t") + (insert "/dcc GET tester " (prin1-to-string file) " -t" (or sep "")) (erc-send-current-line) - (should (eq t (plist-get (car erc-dcc-list) :turbo))) - (should (equal (pop calls) (list elt "foo.bin" proc)))))))) + (should (eq (if sep nil t) (plist-get (car erc-dcc-list) :turbo))) + (should (equal (pop calls) (if sep nil (list elt file proc))))))))) + +(ert-deftest erc-dcc-do-GET-command () + (erc-dcc-tests--erc-dcc-do-GET-command "foo.bin") + (erc-dcc-tests--erc-dcc-do-GET-command "foo - file.bin") + (erc-dcc-tests--erc-dcc-do-GET-command "foo -t file.bin") + (erc-dcc-tests--erc-dcc-do-GET-command "-t" "-- ")) -(defun erc-dcc-tests--pcomplete-common (test-fn) +(defun erc-dcc-tests--pcomplete-common (test-fn &optional file) (with-current-buffer (get-buffer-create "*erc-dcc-do-GET-command*") (let* ((inhibit-message noninteractive) (proc (start-process "fake" (current-buffer) "sleep" "10")) @@ -175,7 +181,7 @@ erc-dcc-tests--pcomplete-common :parent proc :ip "127.0.0.1" :port "9899" - :file "foo.bin" + :file (or file "foo.bin") :size 1405135128)) ;; erc-accidental-paste-threshold-seconds @@ -211,6 +217,20 @@ pcomplete/erc-mode/DCC--get-basic (beginning-of-line) (should (search-forward "/dcc get tester foo.bin" nil t)))))) +(ert-deftest pcomplete/erc-mode/DCC--get-quoted () + (erc-dcc-tests--pcomplete-common + (lambda () + (insert "/dcc get ") + (call-interactively #'completion-at-point) + (save-excursion + (beginning-of-line) + (should (search-forward "/dcc get tester" nil t))) + (call-interactively #'completion-at-point) + (save-excursion + (beginning-of-line) + (should (search-forward "/dcc get tester \"foo bar.bin\"" nil t)))) + "foo bar.bin")) + (ert-deftest pcomplete/erc-mode/DCC--get-1flag () (erc-dcc-tests--pcomplete-common (lambda () @@ -282,4 +302,23 @@ pcomplete/erc-mode/DCC--get-2flags-reverse (beginning-of-line) (should (search-forward "/dcc get -t -s tester foo.bin" nil t)))))) +(ert-deftest pcomplete/erc-mode/DCC--get-sep () + (erc-dcc-tests--pcomplete-common + (lambda () + (insert "/dcc get ") + (call-interactively #'completion-at-point) + (save-excursion + (beginning-of-line) + (should (search-forward "/dcc get tester" nil t))) + (insert "-") + (call-interactively #'completion-at-point) + (save-excursion + (beginning-of-line) + (should (search-forward "/dcc get tester -- " nil t))) + (call-interactively #'completion-at-point) + (save-excursion + (beginning-of-line) + (should (search-forward "/dcc get tester -- -t" nil t)))) + "-t")) + ;;; erc-dcc-tests.el ends here commit 2d3ae5d5e68a21e51105168b1d9503f28e9e98c3 Author: F. Jason Park Date: Sat Mar 25 09:13:40 2023 -0700 Add subcommand erc-cmd-HELP handler to erc-dcc * lisp/erc/erc-compat.el (erc-compat--28-split-string-shell-command, erc-compat--split-string-shell-command): New functions introduced in Emacs 28 for splitting pcomplete input. * lisp/erc/erc-dcc.el (erc-cmd-DCC): Elect to tokenize line specially. (erc-dcc--cmd-help): Add help handler. (Bug#62444.) diff --git a/lisp/erc/erc-compat.el b/lisp/erc/erc-compat.el index 5601ede27a5..e6ae62d3a2e 100644 --- a/lisp/erc/erc-compat.el +++ b/lisp/erc/erc-compat.el @@ -409,6 +409,28 @@ erc-compat--29-browse-url-irc (cons '("\\`irc6?s?://" . erc-compat--29-browse-url-irc) existing)))))) + +;;;; Misc 28.1 + +(defvar comint-file-name-quote-list) +(defvar shell-file-name-quote-list) +(declare-function shell--parse-pcomplete-arguments "shell" nil) + +(defun erc-compat--28-split-string-shell-command (string) + (require 'comint) + (require 'shell) + (with-temp-buffer + (insert string) + (let ((comint-file-name-quote-list shell-file-name-quote-list)) + (car (shell--parse-pcomplete-arguments))))) + +(defmacro erc-compat--split-string-shell-command (string) + ;; Autoloaded in Emacs 28. + (list (if (fboundp 'split-string-shell-command) + 'split-string-shell-command + 'erc-compat--28-split-string-shell-command) + string)) + (provide 'erc-compat) ;;; erc-compat.el ends here diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el index 4c557e0e0f9..70683a92ffc 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el @@ -404,8 +404,16 @@ erc-cmd-DCC (apropos "erc-dcc-do-.*-command") t)))) +(put 'erc-cmd-DCC 'do-not-parse-args t) (autoload 'pcomplete-erc-all-nicks "erc-pcomplete") +;;;###autoload(put 'erc-cmd-DCC 'erc--cmd-help 'erc-dcc--cmd-help) +(defun erc-dcc--cmd-help (&rest args) + (describe-function + (or (and args (intern-soft (concat "erc-dcc-do-" + (upcase (car args)) "-command"))) + 'erc-cmd-DCC))) + ;;;###autoload (defun pcomplete/erc-mode/DCC () "Provide completion for the /DCC command." commit b1007516cdf7a21b44340838d9d9509a81577436 Author: F. Jason Park Date: Sat Mar 25 09:13:40 2023 -0700 Add subcommand dispatch facility to erc-cmd-HELP * lisp/erc/erc.el (erc-cmd-HELP): Change signature by adding &rest parameter. Look for symbol property `erc--cmd-help' and, if found, assume it's a function and call it with &rest args after attempting to autoload the primary command symbol. (Bug#62444.) diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index f0ea7510c65..f76c770f585 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -3204,7 +3204,7 @@ erc-cmd-CTCP (erc-send-ctcp-message nick str) t)) -(defun erc-cmd-HELP (&optional func) +(defun erc-cmd-HELP (&optional func &rest rest) "Popup help information. If FUNC contains a valid function or variable, help about that @@ -3237,6 +3237,10 @@ erc-cmd-HELP nil))))) (if sym (cond + ((get sym 'erc--cmd-help) + (when (autoloadp (symbol-function sym)) + (autoload-do-load (symbol-function sym))) + (apply (get sym 'erc--cmd-help) rest)) ((boundp sym) (describe-variable sym)) ((fboundp sym) (describe-function sym)) (t nil)) commit dfaeeba97cc45015db5a785aa8f94089f960029d Author: F. Jason Park Date: Fri Mar 31 19:42:54 2023 -0700 Change ERC version to 5.6-git * lisp/erc/erc.el: Update main Version header and bump required Compat to latest release in Package-Requires header. Also update entry in `customize-package-emacs-version-alist', mapping ERC 5.6 to Emacs 30.1. (erc-version): Move to 5.6-git. diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index 69bdb5d71b1..f0ea7510c65 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -12,8 +12,8 @@ ;; David Edmondson (dme@dme.org) ;; Michael Olson (mwolson@gnu.org) ;; Kelvin White (kwhite@gnu.org) -;; Version: 5.5 -;; Package-Requires: ((emacs "27.1") (compat "29.1.3.4")) +;; Version: 5.6-git +;; Package-Requires: ((emacs "27.1") (compat "29.1.4.1")) ;; Keywords: IRC, chat, client, Internet ;; URL: https://www.gnu.org/software/emacs/erc.html @@ -71,7 +71,7 @@ (require 'iso8601) (eval-when-compile (require 'subr-x) (require 'url-parse)) -(defconst erc-version "5.5" +(defconst erc-version "5.6-git" "This version of ERC.") (defvar erc-official-location @@ -87,7 +87,8 @@ erc-official-location ("5.3" . "23.1") ("5.4" . "28.1") ("5.4.1" . "29.1") - ("5.5" . "29.1"))) + ("5.5" . "29.1") + ("5.6" . "30.1"))) (defgroup erc nil "Emacs Internet Relay Chat client." commit 685435cb52eaa6f61b7088398f1f53e69d76e63e Author: João Távora Date: Sat Apr 8 20:41:13 2023 +0100 Eglot: simplify eglot--sig-info and fix edge cases (bug#62687) The documentation of each signature was rarely rendered because of obsolete logic that skipped MarkupContent objects. The new function follows the principle that echo are gets as little as possible, while the *eldoc* buffer gets as much as possible (except, for the individual parameter documentation, as I couldn't find a single server that uses it). Tested with clangd, pylsp, jdtls, gopls, rust-analyzer, zls. * lisp/progmodes/eglot.el (eglot--sig-info): Simplify. diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index 6134ab9150c..b10344a706b 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -3118,29 +3118,27 @@ eglot--hover-info (mapconcat #'eglot--format-markup (if (vectorp contents) contents (list contents)) "\n")) -(defun eglot--sig-info (sig &optional _activep sig-help-active-param) +(defun eglot--sig-info (sig &optional sig-help-active-param briefp) (eglot--dbind ((SignatureInformation) label documentation parameters activeParameter) sig (with-temp-buffer (save-excursion (insert label)) (let ((active-param (or activeParameter sig-help-active-param)) + (labeldoc (and (not briefp) documentation + (eglot--format-markup documentation))) params-start params-end) ;; Ad-hoc attempt to parse label as () (when (looking-at "\\([^(]*\\)(\\([^)]+\\))") (setq params-start (match-beginning 2) params-end (match-end 2)) (add-face-text-property (match-beginning 1) (match-end 1) 'font-lock-function-name-face)) - ;; Decide whether to add one-line-summary to signature line - (when (and (stringp documentation) - (string-match "[[:space:]]*\\([^.\r\n]+[.]?\\)" - documentation)) - (setq documentation (match-string 1 documentation)) - (unless (string-prefix-p (string-trim documentation) label) - (goto-char (point-max)) - (insert ": " (eglot--format-markup documentation)))) + ;; Add documentation, indented so we can distinguish multiple signatures + (when labeldoc + (goto-char (point-max)) + (insert "\n" (replace-regexp-in-string "^" " " labeldoc))) ;; Decide what to do with the active parameter... (when (and active-param (< -1 active-param (length parameters))) - (eglot--dbind ((ParameterInformation) label documentation) + (eglot--dbind ((ParameterInformation) label) (aref parameters active-param) ;; ...perhaps highlight it in the formals list (when params-start @@ -3157,17 +3155,7 @@ eglot--sig-info (if (and beg end) (add-face-text-property beg end - 'eldoc-highlight-function-argument)))) - ;; ...and/or maybe add its doc on a line by its own. - (when documentation - (goto-char (point-max)) - (insert "\n" - (propertize - (if (stringp label) - label - (apply #'buffer-substring (mapcar #'1+ label))) - 'face 'eldoc-highlight-function-argument) - ": " (eglot--format-markup documentation)))))) + 'eldoc-highlight-function-argument))))))) (buffer-string)))) (defun eglot-signature-eldoc-function (cb) @@ -3184,9 +3172,13 @@ eglot-signature-eldoc-function (let ((active-sig (and (cl-plusp (length signatures)) (aref signatures (or activeSignature 0))))) (if (not active-sig) (funcall cb nil) - (funcall cb - (mapconcat #'eglot--sig-info signatures "\n") - :echo (eglot--sig-info active-sig t activeParameter)))))) + (funcall + cb (mapconcat (lambda (s) + (eglot--sig-info s (and (eq s active-sig) + activeParameter) + nil)) + signatures "\n") + :echo (eglot--sig-info active-sig activeParameter t)))))) :deferred :textDocument/signatureHelp)) t)) commit aef996cd34f421da6540cccb9cc3ac2153458e36 Author: Mattias Engdegård Date: Sat Apr 8 19:17:17 2023 +0200 Consolidate existing warnings about unused return values Move the warning about unused return values from calls to side-effect-free functions from the source-level optimiser to the code generator, where it can be unified with the special-purpose warning about unused values from `mapcar`. This change also cures spurious duplicate warnings about the same code, makes the warnings amenable to suppression through `with-suppressed-warnings`, and now warns about some unused values that weren't caught before. * lisp/emacs-lisp/byte-opt.el (byte-optimize-form-code-walker): Move warning away from here. * lisp/emacs-lisp/byte-run.el (with-suppressed-warnings): * lisp/emacs-lisp/bytecomp.el (byte-compile-warnings): Doc string updates. (byte-compile-form): Put the new warnings here. (byte-compile-normal-call): Move mapcar warning away from here. * lisp/emacs-lisp/bytecomp.el (byte-compile-ignore): Compile args to `ignore` for value to avoid unused-value warnings, and then discard the generated values immediately thereafter. Mostly this does not affect the generated code but in rare cases it might result in slightly worse code. * test/lisp/emacs-lisp/bytecomp-tests.el (bytecomp-test--with-suppressed-warnings): Adapt test. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 0891ec80beb..70317e2365d 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -506,13 +506,7 @@ byte-optimize-form-code-walker ((guard (when for-effect (if-let ((tmp (byte-opt--fget fn 'side-effect-free))) (or byte-compile-delete-errors - (eq tmp 'error-free) - (progn - (byte-compile-warn-x - form - "value returned from %s is unused" - form) - nil))))) + (eq tmp 'error-free))))) (byte-compile-log " %s called for effect; deleted" fn) (byte-optimize-form (cons 'progn (cdr form)) t)) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 9345665eea8..fd9913d1be8 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -650,11 +650,8 @@ with-suppressed-warnings `byte-compile-warnings' for a fuller explanation of the warning types. The types that can be suppressed with this macro are `free-vars', `callargs', `redefine', `obsolete', -`interactive-only', `lexical', `mapcar', `constants', -`suspicious' and `empty-body'. - -For the `mapcar' case, only the `mapcar' function can be used in -the symbol list." +`interactive-only', `lexical', `ignored-return-value', `constants', +`suspicious' and `empty-body'." ;; Note: during compilation, this definition is overridden by the one in ;; byte-compile-initial-macro-environment. (declare (debug (sexp body)) (indent 1)) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index a122e81ba3c..4a10ae29804 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -317,7 +317,9 @@ byte-compile-warnings lexical-dynamic lexically bound variable declared dynamic elsewhere make-local calls to `make-variable-buffer-local' that may be incorrect. - mapcar mapcar called for effect. + ignored-return-value + function called without using the return value where this + is likely to be a mistake not-unused warning about using variables with symbol names starting with _. constants let-binding of, or assignment to, constants/nonvariables. docstrings docstrings that are too wide (longer than @@ -330,7 +332,7 @@ byte-compile-warnings empty-body body argument to a special form or macro is empty. If the list begins with `not', then the remaining elements specify warnings to -suppress. For example, (not mapcar) will suppress warnings about mapcar. +suppress. For example, (not free-vars) will suppress the `free-vars' warning. The t value means \"all non experimental warning types\", and excludes the types in `byte-compile--emacs-build-warning-types'. @@ -3490,6 +3492,27 @@ byte-compile-form (byte-compile-report-error (format-message "`%s' defined after use in %S (missing `require' of a library file?)" (car form) form))) + + (when byte-compile--for-effect + (let ((sef (function-get (car form) 'side-effect-free))) + (cond + ((and sef (or (eq sef 'error-free) + byte-compile-delete-errors)) + ;; This transform is normally done in the Lisp optimiser, + ;; so maybe we don't need to bother about it here? + (setq form (cons 'progn (cdr form))) + (setq handler #'byte-compile-progn)) + ((and (or sef (eq (car form) 'mapcar)) + (byte-compile-warning-enabled-p + 'ignored-return-value (car form))) + (byte-compile-warn-x + (car form) + "value from call to `%s' is unused%s" + (car form) + (cond ((eq (car form) 'mapcar) + "; use `mapc' or `dolist' instead") + (t ""))))))) + (if (and handler ;; Make sure that function exists. (and (functionp handler) @@ -3523,11 +3546,7 @@ byte-compile-normal-call (byte-compile-callargs-warn form)) (if byte-compile-generate-call-tree (byte-compile-annotate-call-tree form)) - (when (and byte-compile--for-effect (eq (car form) 'mapcar) - (byte-compile-warning-enabled-p 'mapcar 'mapcar)) - (byte-compile-warn-x - (car form) - "`mapcar' called for effect; use `mapc' or `dolist' instead")) + (byte-compile-push-constant (car form)) (mapc 'byte-compile-form (cdr form)) ; wasteful, but faster. (byte-compile-out 'byte-call (length (cdr form)))) @@ -4367,7 +4386,11 @@ byte-compile-goto-if (defun byte-compile-ignore (form) (dolist (arg (cdr form)) - (byte-compile-form arg t)) + ;; Compile args for value (to avoid warnings about unused values), + ;; emit a discard after each, and trust the LAP peephole optimiser + ;; to annihilate useless ops. + (byte-compile-form arg) + (byte-compile-discard)) (byte-compile-form nil)) ;; Return the list of items in CONDITION-PARAM that match PRED-LIST. diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index 5bad1ce41a8..9ade47331df 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -1438,8 +1438,8 @@ bytecomp-test--with-suppressed-warnings '(defun zot () (mapcar #'list '(1 2 3)) nil) - '((mapcar mapcar)) - "Warning: .mapcar. called for effect") + '((ignored-return-value mapcar)) + "Warning: value from call to `mapcar' is unused; use `mapc' or `dolist' instead") (test-suppression '(defun zot () commit 10b58633b566cf8f66f12e2126da3b43cd09dfc8 Author: Basil L. Contovounesios Date: Sat Apr 1 15:14:34 2023 +0100 Improve ibuffer-diff-with-file * lisp/ibuf-ext.el (ibuffer-diff-with-file): Link to diff-command in docstring. Make Diff buffer read-only from outset and inhibit as needed to avoid surprises. Check whether diff-command supports --label. Leave point at BOB and clean up any excess newline inserted by ibuffer-diff-buffer-with-file-1. Prefer pop-to-buffer-same-window over switch-to-buffer. (ibuffer-diff-buffer-with-file-1): Add docstring. Remove unused unwind-protect and copypasta from diff-no-select (bug#62599). Use diff-file-local-copy, string-join, and redisplay in place of analogues. Condition --label use on availability, and label buffers consistently with diff-no-select. Leave empty line between runs. Let diff-sentinel delete temporary files. Leave point at EOB for next run. diff --git a/lisp/ibuf-ext.el b/lisp/ibuf-ext.el index ed4c8a04db7..550b5ed0e6a 100644 --- a/lisp/ibuf-ext.el +++ b/lisp/ibuf-ext.el @@ -1650,68 +1650,67 @@ ibuffer-jump-to-buffer (error "No buffer with name %s" name) (goto-char buf-point))))) +(declare-function diff-check-labels "diff" (&optional force)) +(declare-function diff-file-local-copy "diff" (file-or-buf)) (declare-function diff-sentinel "diff" (code &optional old-temp-file new-temp-file)) (defun ibuffer-diff-buffer-with-file-1 (buffer) - (let ((bufferfile (buffer-local-value 'buffer-file-name buffer)) - (tempfile (make-temp-file "buffer-content-"))) - (when bufferfile - (unwind-protect - (progn - (with-current-buffer buffer - (write-region nil nil tempfile nil 'nomessage)) - (let* ((old (expand-file-name bufferfile)) - (new (expand-file-name tempfile)) - (oldtmp (file-local-copy old)) - (newtmp (file-local-copy new)) - (switches diff-switches) - (command - (mapconcat - 'identity - `(,diff-command - ;; Use explicitly specified switches - ,@(if (listp switches) switches (list switches)) - ,@(if (or old new) - (list "-L" (shell-quote-argument old) - "-L" (shell-quote-argument - (format "Buffer %s" (buffer-name buffer))))) - ,(shell-quote-argument (or oldtmp old)) - ,(shell-quote-argument (or newtmp new))) - " "))) - (let ((inhibit-read-only t)) - (insert command "\n") - (diff-sentinel - (call-process shell-file-name nil - (current-buffer) nil - shell-command-switch command)) - (insert "\n"))))) - (sit-for 0) - (when (file-exists-p tempfile) - (delete-file tempfile))))) + "Compare BUFFER with its associated file, if any. +Unlike `diff-no-select', insert output into current buffer +without erasing it." + (when-let ((old (buffer-file-name buffer))) + (defvar diff-use-labels) + (let* ((new buffer) + (oldtmp (diff-file-local-copy old)) + (newtmp (diff-file-local-copy new)) + (switches diff-switches) + (command + (string-join + `(,diff-command + ,@(if (listp switches) switches (list switches)) + ,@(and (eq diff-use-labels t) + (list "--label" (shell-quote-argument old) + "--label" (shell-quote-argument (format "%S" new)))) + ,(shell-quote-argument (or oldtmp old)) + ,(shell-quote-argument (or newtmp new))) + " ")) + (inhibit-read-only t)) + (insert ?\n command ?\n) + (diff-sentinel (call-process shell-file-name nil t nil + shell-command-switch command) + oldtmp newtmp) + (goto-char (point-max))) + (redisplay))) ;;;###autoload (defun ibuffer-diff-with-file () "View the differences between marked buffers and their associated files. If no buffers are marked, use buffer at point. -This requires the external program \"diff\" to be in your `exec-path'." +This requires the external program `diff-command' to be in your +`exec-path'." (interactive) (require 'diff) - (let ((marked-bufs (ibuffer-get-marked-buffers))) - (when (null marked-bufs) - (setq marked-bufs (list (ibuffer-current-buffer t)))) - (with-current-buffer (get-buffer-create "*Ibuffer Diff*") - (setq buffer-read-only nil) - (buffer-disable-undo (current-buffer)) - (erase-buffer) - (buffer-enable-undo (current-buffer)) + (let ((marked-bufs (or (ibuffer-get-marked-buffers) + (list (ibuffer-current-buffer t)))) + (diff-buf (get-buffer-create "*Ibuffer Diff*"))) + (with-current-buffer diff-buf + (setq buffer-read-only t) + (buffer-disable-undo) + (let ((inhibit-read-only t)) + (erase-buffer)) + (buffer-enable-undo) (diff-mode) + (diff-check-labels) (dolist (buf marked-bufs) (unless (buffer-live-p buf) (error "Buffer %s has been killed" buf)) - (ibuffer-diff-buffer-with-file-1 buf)) - (setq buffer-read-only t))) - (switch-to-buffer "*Ibuffer Diff*")) + (ibuffer-diff-buffer-with-file-1 buf)) + (goto-char (point-min)) + (when (= (following-char) ?\n) + (let ((inhibit-read-only t)) + (delete-char 1)))) + (pop-to-buffer-same-window diff-buf))) ;;;###autoload (defun ibuffer-copy-filename-as-kill (&optional arg)