diff options
32 files changed, 643 insertions, 379 deletions
diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index 22c50936185..4002004cd6f 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -2511,7 +2511,10 @@ If non-@code{nil}, always ask for the server's capabilities, even when doing a @samp{plain} connection. @item :capability-command @var{capability-command} -Command string to query the host capabilities. +Command to query the host capabilities. This can either be a string +(which will then be sent verbatim to the server), or a function +(called with a single parameter; the "greeting" from the server when +connecting), and should return a string. @item :end-of-command @var{regexp} @itemx :end-of-capability @var{regexp} diff --git a/doc/misc/eww.texi b/doc/misc/eww.texi index e3191cbe48a..9bca0faa854 100644 --- a/doc/misc/eww.texi +++ b/doc/misc/eww.texi @@ -283,6 +283,14 @@ contrast. If that is still too low for you, you can customize the variables @code{shr-color-visible-distance-min} and @code{shr-color-visible-luminance-min} to get a better contrast. +@vindex shr-max-width +@vindex shr-width + By default, the max width used when rendering is 120 characters, but +this can be adjusted by changing the @code{shr-max-width} variable. +If a specified width is preferred no matter what the width of the +window is, @code{shr-width} can be set. If both variables are +@code{nil}, the window width will always be used. + @vindex shr-discard-aria-hidden @cindex @code{aria-hidden}, HTML attribute The HTML attribute @code{aria-hidden} is meant to tell screen diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index 718e269fc86..2f4bc0cbf85 100644 --- a/doc/misc/gnus.texi +++ b/doc/misc/gnus.texi @@ -436,7 +436,7 @@ Starting Gnus * Finding the News:: Choosing a method for getting news. * The Server is Down:: How can I read my mail then? -* Slave Gnusae:: You can have more than one Gnus active at a time. +* Child Gnusae:: You can have more than one Gnus active at a time. * Fetching a Group:: Starting Gnus just to read a group. * New Groups:: What is Gnus supposed to do with new groups? * Changing Servers:: You may want to move from one server to another. @@ -976,7 +976,7 @@ terminology section (@pxref{Terminology}). @menu * Finding the News:: Choosing a method for getting news. * The Server is Down:: How can I read my mail then? -* Slave Gnusae:: You can have more than one Gnus active at a time. +* Child Gnusae:: You can have more than one Gnus active at a time. * New Groups:: What is Gnus supposed to do with new groups? * Changing Servers:: You may want to move from one server to another. * Startup Files:: Those pesky startup files---@file{.newsrc}. @@ -1090,9 +1090,9 @@ your primary server---instead, it will just activate all groups on level levels.) Also @pxref{Group Levels}. -@node Slave Gnusae -@section Slave Gnusae -@cindex slave +@node Child Gnusae +@section Child Gnusae +@cindex child You might want to run more than one Emacs with more than one Gnus at the same time. If you are using different @file{.newsrc} files (e.g., if you @@ -1103,31 +1103,27 @@ The problem appears when you want to run two Gnusae that use the same @file{.newsrc} file. To work around that problem some, we here at the Think-Tank at the Gnus -Towers have come up with a new concept: @dfn{Masters} and -@dfn{slaves}. (We have applied for a patent on this concept, and have -taken out a copyright on those words. If you wish to use those words in -conjunction with each other, you have to send $1 per usage instance to -me. Usage of the patent (@dfn{Master/Slave Relationships In Computer -Applications}) will be much more expensive, of course.) - -@findex gnus-slave +Towers have come up with a new concept: @dfn{Parents} and +@dfn{children}. + +@findex gnus-child Anyway, you start one Gnus up the normal way with @kbd{M-x gnus} (or -however you do it). Each subsequent slave Gnusae should be started with -@kbd{M-x gnus-slave}. These slaves won't save normal @file{.newsrc} -files, but instead save @dfn{slave files} that contain information only -on what groups have been read in the slave session. When a master Gnus -starts, it will read (and delete) these slave files, incorporating all -information from them. (The slave files will be read in the sequence +however you do it). Each subsequent child Gnusae should be started with +@kbd{M-x gnus-child}. These children won't save normal @file{.newsrc} +files, but instead save @dfn{child files} that contain information only +on what groups have been read in the child session. When a parent Gnus +starts, it will read (and delete) these child files, incorporating all +information from them. (The child files will be read in the sequence they were created, so the latest changes will have precedence.) -Information from the slave files has, of course, precedence over the -information in the normal (i.e., master) @file{.newsrc} file. +Information from the child files has, of course, precedence over the +information in the normal (i.e., parent) @file{.newsrc} file. -If the @file{.newsrc*} files have not been saved in the master when the -slave starts, you may be prompted as to whether to read an auto-save -file. If you answer ``yes'', the unsaved changes to the master will be -incorporated into the slave. If you answer ``no'', the slave may see some -messages as unread that have been read in the master. +If the @file{.newsrc*} files have not been saved in the parent when the +child starts, you may be prompted as to whether to read an auto-save +file. If you answer ``yes'', the unsaved changes to the parent will be +incorporated into the child. If you answer ``no'', the child may see some +messages as unread that have been read in the parent. @@ -9064,6 +9060,9 @@ when filling. @findex gnus-article-fill-long-lines Fill long lines (@code{gnus-article-fill-long-lines}). +You can give the command a numerical prefix to specify the width to use +when filling. + @item W C @kindex W C @r{(Summary)} @findex gnus-article-capitalize-sentences @@ -28487,9 +28486,9 @@ entry. The format spec @code{%C} for positioning point has changed to @code{%*}. @item -@code{gnus-slave-unplugged} +@code{gnus-child-unplugged} -A new command which starts Gnus offline in slave mode. +A new command which starts Gnus offline in child mode. @end itemize @@ -207,6 +207,16 @@ Bookmark locations can refer to VC directory buffers. ** Gnus ++++ +*** The name of dependent Gnus sessions has changed from "slave" to "child". +The names of the commands 'gnus-slave', 'gnus-slave-no-server' and +'gnus-slave-unplugged' have changed to 'gnus-child', +'gnus-child-no-server' and 'gnus-child-unplugged' respectively. + ++++ +*** The 'W Q' summary mode command now takes a numerical prefix to +allow adjusting the fill width. + --- *** Change to default value of 'message-draft-headers' user option. The 'Date' symbol has been removed from the default value, meaning that @@ -470,6 +480,16 @@ This is still the case by default, but if you customize 'browse-url-mailto-function' or 'browse-url-handlers' to call some other function, it will now be called instead of the default. ++++ +*** New variable 'shr-max-width'. +If this variable is non-nil, and 'shr-width' is nil, then SHR will use +the value of 'shr-max-width' to limit the width of the rendered HTML. +The default is 120 characters, so even if you have very wide frames, +HTML text will be rendered more narrowly, which usually leads to a +more readable text. Set this variable to nil to get the previous +behavior of rendering as wide as the window-width allows. If +'shr-width' is non-nil, it overrides this variable. + ** EWW --- @@ -542,13 +562,14 @@ truncation, amongst other things. 'bug-reference-prog-mode' have been activated, their respective hook has been run and still 'bug-reference-bug-regexp' and 'bug-reference-url-format' aren't both set, it tries to guess -appropriate values for those two variables. There are two guessing +appropriate values for those two variables. There are three guessing mechanisms so far: based on version control information of the current -buffer's file, and based on newsgroup/mail-folder name and several -news and mail message headers in Gnus buffers. Both mechanisms are -extensible with custom rules, see the variables -'bug-reference-setup-from-vc-alist' and -'bug-reference-setup-from-mail-alist'. +buffer's file, based on newsgroup/mail-folder name and several news +and mail message headers in Gnus buffers, and based on IRC channel and +server in rcirc buffers. All mechanisms are extensible with custom +rules, see the variables 'bug-reference-setup-from-vc-alist', +'bug-reference-setup-from-mail-alist', and +'bug-reference-setup-from-irc-alist'. * New Modes and Packages in Emacs 28.1 @@ -670,6 +691,12 @@ for encoding and decoding without having to bind 'coding-system-for-{read,write}' or call 'set-process-coding-system'. +++ +** 'open-network-stream' can now take a :capability-command that's a function. +The function is called with the greeting from the server as its only +parameter, and allows sending different TLS capability commands to the +server based on that greeting. + ++++ ** 'open-gnutls-stream' now also accepts a ':coding' argument. +++ diff --git a/lisp/descr-text.el b/lisp/descr-text.el index be5e01435a7..55f0b7dcb40 100644 --- a/lisp/descr-text.el +++ b/lisp/descr-text.el @@ -781,8 +781,8 @@ The character information includes: (let ((chars (match-string 1 (car composition)))) (dotimes (i (length chars)) (let ((char (aref chars i))) - (insert (format " %c (#x%x) %s\n" - char char + (insert (format " %s (#x%x) %s\n" + (describe-char-padded-string char) char (get-char-code-property char 'name)))))))) ;; TTY frame: show composition in terms of characters. diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 510dff9ed0b..6ed5bff9f44 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -429,7 +429,7 @@ Honor most of `eldoc-echo-area-use-multiline-p'." (integer val) (t 1))) (things-reported-on) - single-sym-name) + single-doc single-doc-sym) ;; Then, compose the contents of the `*eldoc*' buffer. (with-current-buffer (eldoc-doc-buffer) (let ((inhibit-read-only t)) @@ -454,20 +454,24 @@ Honor most of `eldoc-echo-area-use-multiline-p'." (mapconcat (lambda (s) (format "%s" s)) things-reported-on ", "))))) - ;; Finally, output to the echo area. We handle the - ;; `truncate-sym-name-if-fit' special case first, by selecting a - ;; top-section of the `*eldoc' buffer. I'm pretty sure nicer + ;; Finally, output to the echo area. I'm pretty sure nicer ;; strategies can be used here, probably by splitting this ;; function into some `eldoc-display-functions' special hook. (let ((echo-area-message (cond - ((and + (;; We handle the `truncate-sym-name-if-fit' special + ;; case first, by checking if for a lot of special + ;; conditions. + (and (eq 'truncate-sym-name-if-fit eldoc-echo-area-use-multiline-p) (null (cdr docs)) - (setq single-sym-name + (setq single-doc (caar docs)) + (setq single-doc-sym (format "%s" (plist-get (cdar docs) :thing))) - (> (+ (length (caar docs)) (length single-sym-name) 2) width)) - (caar docs)) + (< (length single-doc) width) + (not (string-match "\n" single-doc)) + (> (+ (length single-doc) (length single-doc-sym) 2) width)) + single-doc) ((> available 1) (with-current-buffer (eldoc-doc-buffer) (cl-loop @@ -497,7 +501,7 @@ Honor most of `eldoc-echo-area-use-multiline-p'." ;; Truncate "brutally." ; FIXME: use `eldoc-prefer-doc-buffer' too? (with-current-buffer (eldoc-doc-buffer) (truncate-string-to-width - (buffer-substring (point-min) (line-end-position 1)) width)))))) + (buffer-substring (goto-char (point-min)) (line-end-position 1)) width)))))) (when echo-area-message (eldoc--message echo-area-message)))))) @@ -664,75 +668,75 @@ have the following values: "Invoke `eldoc-documentation-strategy' function. That function's job is to run the `eldoc-documentation-functions' -special hook, using the `run-hook' family of functions. The way -we invoke it here happens in a way strategy function can itself -call `eldoc--make-callback' to produce values to give to the -elements of the special hook `eldoc-documentation-functions'. - -For each element of `eldoc-documentation-functions' invoked a -corresponding call to `eldoc--make-callback' must be made. See -docstring of `eldoc--make-callback' for the types of callback -that can be produced. - -If the strategy function does not use `eldoc--make-callback', it -must find some alternate way to produce callbacks to feed to -`eldoc-documentation-function', and those callbacks should -endeavour to display the docstrings given to them." - (let* (;; how many docstrings callbaks have been +special hook, using the `run-hook' family of functions. ElDoc's +built-in strategy functions play along with the +`eldoc--make-callback' protocol, using it to produce callback to +feed to the functgions of `eldoc-documentation-functions'. + +Other third-party strategy functions do not use +`eldoc--make-callback'. They must find some alternate way to +produce callbacks to feed to `eldoc-documentation-function' and +should endeavour to display the docstrings eventually produced." + (let* (;; How many callbacks have been created by the strategy + ;; fucntion and passed to elements of + ;; `eldoc-documentation-functions'. (howmany 0) - ;; how many calls to callbacks we're waiting on. Used by - ;; `:patient'. + ;; How many calls to callbacks we're still waiting on. Used + ;; by `:patient'. (want 0) - ;; how many doc strings and corresponding options have been - ;; registered it. + ;; The doc strings and corresponding options registered so + ;; far. (docs-registered '())) - (cl-labels - ((register-doc (pos string plist) - (when (and string (> (length string) 0)) - (push (cons pos (cons string plist)) docs-registered))) - (display-doc () - (eldoc--handle-docs - (mapcar #'cdr - (setq docs-registered - (sort docs-registered - (lambda (a b) (< (car a) (car b)))))))) - (make-callback (method) - (let ((pos (prog1 howmany (cl-incf howmany)))) - (cl-ecase method - (:enthusiast - (lambda (string &rest plist) - (when (and string (cl-loop for (p) in docs-registered - never (< p pos))) - (setq docs-registered '()) - (register-doc pos string plist) - (when (and (timerp eldoc--enthusiasm-curbing-timer) - (memq eldoc--enthusiasm-curbing-timer - timer-list)) - (cancel-timer eldoc--enthusiasm-curbing-timer)) - (setq eldoc--enthusiasm-curbing-timer - (run-at-time (unless (zerop pos) 0.3) - nil #'display-doc))) - t)) - (:patient - (cl-incf want) - (lambda (string &rest plist) - (register-doc pos string plist) - (when (zerop (cl-decf want)) (display-doc)) - t)) - (:eager - (lambda (string &rest plist) - (register-doc pos string plist) - (display-doc) - t)))))) - (let* ((eldoc--make-callback #'make-callback) - (res (funcall eldoc-documentation-strategy))) - ;; Observe the old and the new protocol: - (cond (;; Old protocol: got string, output immediately; - (stringp res) (register-doc 0 res nil) (display-doc)) - (;; Old protocol: got nil, clear the echo area; - (null res) (eldoc--message nil)) - (;; New protocol: trust callback will be called; - t)))))) + (cl-labels + ((register-doc + (pos string plist) + (when (and string (> (length string) 0)) + (push (cons pos (cons string plist)) docs-registered))) + (display-doc + () + (eldoc--handle-docs + (mapcar #'cdr + (setq docs-registered + (sort docs-registered + (lambda (a b) (< (car a) (car b)))))))) + (make-callback + (method) + (let ((pos (prog1 howmany (cl-incf howmany)))) + (cl-ecase method + (:enthusiast + (lambda (string &rest plist) + (when (and string (cl-loop for (p) in docs-registered + never (< p pos))) + (setq docs-registered '()) + (register-doc pos string plist) + (when (and (timerp eldoc--enthusiasm-curbing-timer) + (memq eldoc--enthusiasm-curbing-timer + timer-list)) + (cancel-timer eldoc--enthusiasm-curbing-timer)) + (setq eldoc--enthusiasm-curbing-timer + (run-at-time (unless (zerop pos) 0.3) + nil #'display-doc))) + t)) + (:patient + (cl-incf want) + (lambda (string &rest plist) + (register-doc pos string plist) + (when (zerop (cl-decf want)) (display-doc)) + t)) + (:eager + (lambda (string &rest plist) + (register-doc pos string plist) + (display-doc) + t)))))) + (let* ((eldoc--make-callback #'make-callback) + (res (funcall eldoc-documentation-strategy))) + ;; Observe the old and the new protocol: + (cond (;; Old protocol: got string, output immediately; + (stringp res) (register-doc 0 res nil) (display-doc)) + (;; Old protocol: got nil, clear the echo area; + (null res) (eldoc--message nil)) + (;; New protocol: trust callback will be called; + t)))))) (defun eldoc-print-current-symbol-info (&optional interactive) "Document thing at point." diff --git a/lisp/emacs-lisp/text-property-search.el b/lisp/emacs-lisp/text-property-search.el index b6e98f59a7a..61bd98d3cfe 100644 --- a/lisp/emacs-lisp/text-property-search.el +++ b/lisp/emacs-lisp/text-property-search.el @@ -137,11 +137,19 @@ and if a matching region is found, moves point to its beginning." nil) ;; We're standing in the property we're looking for, so find the ;; end. - ((and (text-property--match-p - value (get-text-property (1- (point)) property) - predicate) - (not not-current)) - (text-property--find-end-backward (1- (point)) property value predicate)) + ((text-property--match-p + value (get-text-property (1- (point)) property) + predicate) + (let ((origin (point)) + (match (text-property--find-end-backward + (1- (point)) property value predicate))) + ;; When we want to ignore the current element, then repeat the + ;; search if we haven't moved out of it yet. + (if (and not-current + (equal (get-text-property (point) property) + (get-text-property origin property))) + (text-property-search-backward property value predicate) + match))) (t (let ((origin (point)) (ended nil) diff --git a/lisp/frame.el b/lisp/frame.el index 77080b76e4f..081d3010e9b 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -1083,7 +1083,8 @@ When `switch-to-buffer-obey-display-actions' is non-nil, (cons (display-buffer-pop-up-frame buffer (append '((inhibit-same-window . t)) alist)) - 'frame))) + 'frame)) + nil "[other-frame]") (message "Display next command buffer in a new frame...")) (defun iconify-or-deiconify-frame () diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index 1ed5000eb36..88873f47bd5 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -603,11 +603,22 @@ manipulated as follows: (gnus)) ;;;###autoload +(defun gnus-child-unplugged (&optional arg) + "Read news as a child unplugged." + (interactive "P") + (setq gnus-plugged nil) + (gnus arg nil 'child)) + +;;;###autoload (defun gnus-slave-unplugged (&optional arg) - "Read news as a slave unplugged." + "Read news as a child unplugged." (interactive "P") (setq gnus-plugged nil) - (gnus arg nil 'slave)) + (gnus arg nil 'child)) +(make-obsolete 'gnus-slave-unplugged 'gnus-child-unplugged "28.1") + + + ;;;###autoload (defun gnus-agentize () diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 614651afff9..cb20d7102bd 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -2303,21 +2303,27 @@ long lines if and only if arg is positive." "\n") (put-text-property start (point) 'gnus-decoration 'header))))) -(defun article-fill-long-lines () - "Fill lines that are wider than the window width." - (interactive) +(defun article-fill-long-lines (&optional width) + "Fill lines that are wider than the window width or `fill-column'. +If WIDTH (interactively, the numeric prefix), use that as the +fill width." + (interactive "P") (save-excursion - (let ((inhibit-read-only t) - (width (window-width (get-buffer-window (current-buffer))))) + (let* ((inhibit-read-only t) + (window-width (window-width (get-buffer-window (current-buffer)))) + (width (if width + (prefix-numeric-value width) + (min fill-column window-width)))) (save-restriction (article-goto-body) (let ((adaptive-fill-mode nil)) ;Why? -sm (while (not (eobp)) (end-of-line) - (when (>= (current-column) (min fill-column width)) + (when (>= (current-column) width) (narrow-to-region (min (1+ (point)) (point-max)) (point-at-bol)) - (let ((goback (point-marker))) + (let ((goback (point-marker)) + (fill-column width)) (fill-paragraph nil) (goto-char (marker-position goback))) (widen)) @@ -4406,6 +4412,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is "e" gnus-article-read-summary-keys "\C-d" gnus-article-read-summary-keys + "\C-c\C-f" gnus-summary-mail-forward "\M-*" gnus-article-read-summary-keys "\M-#" gnus-article-read-summary-keys "\M-^" gnus-article-read-summary-keys @@ -6674,7 +6681,7 @@ not have a face in `gnus-article-boring-faces'." (interactive "P") (gnus-article-check-buffer) (let ((nosaves - '("q" "Q" "r" "\C-c\C-f" "m" "a" "f" "WDD" "WDW" + '("q" "Q" "r" "m" "a" "f" "WDD" "WDW" "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" "=" "^" "\M-^" "|")) (nosave-but-article @@ -7718,6 +7725,15 @@ positives are possible." 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-variable 1) ("M-x[ \t\n]+apropos-documentation[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>" 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-documentation 1) + ;; This is how URLs _should_ be embedded in text (RFC 1738, RFC 2396)... + ("<URL: *\\([^\n<>]*\\)>" + 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) + ;; RFC 2396 (2.4.3., delims) ... + ("\"URL: *\\([^\n\"]*\\)\"" + 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) + ;; Raw URLs. + (gnus-button-url-regexp + 0 (>= gnus-button-browse-level 0) browse-url-button-open-url 0) ;; The following entries may lead to many false positives so don't enable ;; them by default (use a high button level). ("/\\([a-z][-a-z0-9]+\\.el\\)\\>[^.?]" @@ -7741,15 +7757,6 @@ positives are possible." ;; Unlike the other regexps we really have to require quoting ;; here to determine where it ends. 1 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-key 3) - ;; This is how URLs _should_ be embedded in text (RFC 1738, RFC 2396)... - ("<URL: *\\([^\n<>]*\\)>" - 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) - ;; RFC 2396 (2.4.3., delims) ... - ("\"URL: *\\([^\n\"]*\\)\"" - 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) - ;; Raw URLs. - (gnus-button-url-regexp - 0 (>= gnus-button-browse-level 0) browse-url-button-open-url 0) ;; man pages ("\\b\\([a-z][a-z]+([1-9])\\)\\W" 0 (and (>= gnus-button-man-level 1) (< gnus-button-man-level 3)) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index da7db589ec3..b207c4f1e06 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -1129,8 +1129,8 @@ The following commands are available: (gnus-update-group-mark-positions) (when gnus-use-undo (gnus-undo-mode 1)) - (when gnus-slave - (gnus-slave-mode))) + (when gnus-child + (gnus-child-mode))) (defun gnus-update-group-mark-positions () (save-excursion @@ -4024,9 +4024,9 @@ otherwise all levels below ARG will be scanned too." (gnus-run-hooks 'gnus-get-top-new-news-hook) (gnus-run-hooks 'gnus-get-new-news-hook) - ;; Read any slave files. - (unless gnus-slave - (gnus-master-read-slave-newsrc)) + ;; Read any child files. + (unless gnus-child + (gnus-parent-read-child-newsrc)) (gnus-get-unread-articles (gnus-group-default-level arg t) nil one-level) diff --git a/lisp/gnus/gnus-kill.el b/lisp/gnus/gnus-kill.el index 5edbaaf201b..a772281d4c3 100644 --- a/lisp/gnus/gnus-kill.el +++ b/lisp/gnus/gnus-kill.el @@ -653,7 +653,7 @@ Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score" gnus-options-not-subscribe) ;; Eat all arguments. (setq command-line-args-left nil) - (gnus-slave) + (gnus-child) ;; Apply kills to specified newsgroups in command line arguments. (setq newsrc (cdr gnus-newsrc-alist)) (while (setq info (pop newsrc)) diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index daaea3980b5..cdfbf16db5e 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -1510,7 +1510,11 @@ If YANK is non-nil, include the original article." (gnus-inews-yank-articles (list (cdr gnus-article-current))))))) (defun gnus-bug (subject) - "Send a bug report to the Emacs maintainers." + "Send a bug report to the Emacs maintainers. + +Already submitted bugs can be found in the Emacs bug tracker: + + https://debbugs.gnu.org/cgi/pkgreport.cgi?package=emacs;max-bugs=100;base-order=1;bug-rev=1" (interactive "sBug Subject: ") (report-emacs-bug subject) (save-excursion diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index f306889a7fc..1ac1d05e033 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -449,19 +449,21 @@ This is not required after changing `gnus-registry-cache-file'." to subject sender recipients))) (defun gnus-registry-spool-action (id group &optional subject sender recipients) - (let ((to (gnus-group-guess-full-name-from-command-method group)) - (recipients (or recipients - (gnus-registry-sort-addresses - (or (message-fetch-field "cc") "") - (or (message-fetch-field "to") "")))) - (subject (or subject (message-fetch-field "subject"))) - (sender (or sender (message-fetch-field "from")))) - (when (and (stringp id) (string-match "\r$" id)) - (setq id (substring id 0 -1))) - (gnus-message 7 "Gnus registry: article %s spooled to %s" - id - to) - (gnus-registry-handle-action id nil to subject sender recipients))) + (save-restriction + (message-narrow-to-headers-or-head) + (let ((to (gnus-group-guess-full-name-from-command-method group)) + (recipients (or recipients + (gnus-registry-sort-addresses + (or (message-fetch-field "cc") "") + (or (message-fetch-field "to") "")))) + (subject (or subject (message-fetch-field "subject"))) + (sender (or sender (message-fetch-field "from")))) + (when (and (stringp id) (string-match "\r$" id)) + (setq id (substring id 0 -1))) + (gnus-message 7 "Gnus registry: article %s spooled to %s" + id + to) + (gnus-registry-handle-action id nil to subject sender recipients)))) (defun gnus-registry-handle-action (id from to subject sender &optional recipients) diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index 873923e6c57..78e07498de7 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -730,7 +730,7 @@ the first newsgroup." ;; Remove Gnus frames. (gnus-kill-gnus-frames)) -(defun gnus-no-server-1 (&optional arg slave) +(defun gnus-no-server-1 (&optional arg child) "Read network news. If ARG is a positive number, Gnus will use that as the startup level. If ARG is nil, Gnus will be started at level 2 @@ -739,11 +739,11 @@ and not a positive number, Gnus will prompt the user for the name of an NNTP server to use. As opposed to \\[gnus], this command will not connect to the local server." (let ((val (or arg (1- gnus-level-default-subscribed)))) - (gnus val t slave) + (gnus val t child) (make-local-variable 'gnus-group-use-permanent-levels) (setq gnus-group-use-permanent-levels val))) -(defun gnus-1 (&optional arg dont-connect slave) +(defun gnus-1 (&optional arg dont-connect child) "Read network news. If ARG is non-nil and a positive number, Gnus will use that as the startup level. If ARG is non-nil and not a positive number, Gnus will @@ -761,7 +761,7 @@ prompt the user for the name of an NNTP server to use." (gnus-splash) (gnus-run-hooks 'gnus-before-startup-hook) (nnheader-init-server-buffer) - (setq gnus-slave slave) + (setq gnus-child child) (gnus-read-init-file) ;; Add "native" to gnus-predefined-server-alist just to have a @@ -790,7 +790,7 @@ prompt the user for the name of an NNTP server to use." (gnus-make-newsrc-file gnus-startup-file)) ;; Read the dribble file. - (when (or gnus-slave gnus-use-dribble-file) + (when (or gnus-child gnus-use-dribble-file) (gnus-dribble-read-file)) ;; Do the actual startup. @@ -1008,11 +1008,11 @@ If LEVEL is non-nil, the news will be set up at level LEVEL." ;; Possibly eval the dribble file. (and init - (or gnus-use-dribble-file gnus-slave) + (or gnus-use-dribble-file gnus-child) (gnus-dribble-eval-file)) - ;; Slave Gnusii should then clear the dribble buffer. - (when (and init gnus-slave) + ;; Child Gnusii should then clear the dribble buffer. + (when (and init gnus-child) (gnus-dribble-clear)) (gnus-update-format-specifications) @@ -1030,7 +1030,7 @@ If LEVEL is non-nil, the news will be set up at level LEVEL." ;; Find new newsgroups and treat them. (when (and init gnus-check-new-newsgroups (not level) (gnus-check-server gnus-select-method) - (not gnus-slave) + (not gnus-child) gnus-plugged) (gnus-find-new-newsgroups)) @@ -1040,8 +1040,8 @@ If LEVEL is non-nil, the news will be set up at level LEVEL." (gnus-server-opened gnus-select-method)) (gnus-check-bogus-newsgroups)) - ;; Read any slave files. - (gnus-master-read-slave-newsrc) + ;; Read any child files. + (gnus-parent-read-child-newsrc) ;; Find the number of unread articles in each non-dead group. (let ((gnus-read-active-file (and (not level) gnus-read-active-file))) @@ -2737,15 +2737,15 @@ values from `gnus-newsrc-hashtb', and write a new value of (gnus-agent-save-local force)) (save-excursion - (if (and (or gnus-use-dribble-file gnus-slave) + (if (and (or gnus-use-dribble-file gnus-child) (not force) (or (not (buffer-live-p gnus-dribble-buffer)) (zerop (with-current-buffer gnus-dribble-buffer (buffer-size))))) (gnus-message 4 "(No changes need to be saved)") (gnus-run-hooks 'gnus-save-newsrc-hook) - (if gnus-slave - (gnus-slave-save-newsrc) + (if gnus-child + (gnus-child-save-newsrc) ;; Save .newsrc only if the select method is an NNTP method. ;; The .newsrc file is for interoperability with other ;; newsreaders, so saving non-NNTP groups there doesn't make @@ -2988,55 +2988,61 @@ SPECIFIC-VARIABLES, or those in `gnus-variable-list'." ;;; -;;; Slave functions. +;;; Child functions. ;;; -(defvar gnus-slave-mode nil) +(defvar gnus-child-mode nil) -(defun gnus-slave-mode () - "Minor mode for slave Gnusae." - ;; FIXME: gnus-slave-mode appears to never be set (i.e. it'll always be nil): +(defun gnus-child-mode () + "Minor mode for child Gnusae." + ;; FIXME: gnus-child-mode appears to never be set (i.e. it'll always be nil): ;; Remove, or fix and use define-minor-mode. - (add-minor-mode 'gnus-slave-mode " Slave" (make-sparse-keymap)) - (gnus-run-hooks 'gnus-slave-mode-hook)) + (add-minor-mode 'gnus-child-mode " Child" (make-sparse-keymap)) + (gnus-run-hooks 'gnus-child-mode-hook)) -(defun gnus-slave-save-newsrc () +(define-obsolete-function-alias 'gnus-slave-mode #'gnus-child-mode "28.1") +(define-obsolete-variable-alias 'gnus-slave-mode-hook 'gnus-child-mode-hook + "28.1") + +(defun gnus-child-save-newsrc () (with-current-buffer gnus-dribble-buffer (with-file-modes (or (ignore-errors (file-modes (concat gnus-current-startup-file ".eld"))) (default-file-modes)) - (let ((slave-name - (make-temp-file (concat gnus-current-startup-file "-slave-")))) + (let ((child-name + (make-temp-file (concat gnus-current-startup-file "-child-")))) (let ((coding-system-for-write gnus-ding-file-coding-system)) - (gnus-write-buffer slave-name)))))) + (gnus-write-buffer child-name)))))) -(defun gnus-master-read-slave-newsrc () - (let ((slave-files +(defun gnus-parent-read-child-newsrc () + (let ((child-files (directory-files (file-name-directory gnus-current-startup-file) t (concat "^" (regexp-quote - (concat - (file-name-nondirectory gnus-current-startup-file) - "-slave-"))) + (file-name-nondirectory gnus-current-startup-file)) + ;; When the obsolete variables like + ;; `gnus-slave-mode-hook' etc are removed, the "slave" + ;; bit of this regexp should also be removed. + "\\(-child-\\|-slave-\\)") t)) file) - (if (not slave-files) - () ; There are no slave files to read. - (gnus-message 7 "Reading slave newsrcs...") - (with-current-buffer (gnus-get-buffer-create " *gnus slave*") - (setq slave-files + (if (not child-files) + () ; There are no child files to read. + (gnus-message 7 "Reading child newsrcs...") + (with-current-buffer (gnus-get-buffer-create " *gnus child*") + (setq child-files (sort (mapcar (lambda (file) (list (file-attribute-modification-time (file-attributes file)) file)) - slave-files) + child-files) (lambda (f1 f2) (time-less-p (car f1) (car f2))))) - (while slave-files + (while child-files (erase-buffer) - (setq file (nth 1 (car slave-files))) + (setq file (nth 1 (car child-files))) (nnheader-insert-file-contents file) (when (condition-case () (progn @@ -3045,12 +3051,12 @@ SPECIFIC-VARIABLES, or those in `gnus-variable-list'." (error (gnus-error 3.2 "Possible error in %s" file) nil)) - (unless gnus-slave ; Slaves shouldn't delete these files. + (unless gnus-child ; Children shouldn't delete these files. (ignore-errors (delete-file file)))) - (setq slave-files (cdr slave-files)))) + (setq child-files (cdr child-files)))) (gnus-dribble-touch) - (gnus-message 7 "Reading slave newsrcs...done")))) + (gnus-message 7 "Reading child newsrcs...done")))) ;;; diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 341f04ad772..d731893ecec 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -5352,7 +5352,8 @@ or a straight list of headers." ;; We remember that we probably want to output a dummy ;; root. (setq gnus-tmp-dummy-line gnus-tmp-header) - (setq gnus-tmp-prev-subject gnus-tmp-header)) + (setq gnus-tmp-prev-subject + (gnus-simplify-subject-fully gnus-tmp-header))) (t ;; We do not make a root for the gathered ;; sub-threads at all. @@ -7331,6 +7332,8 @@ If FORCE (the prefix), also save the .newsrc file(s)." (gnus-group-next-unread-group 1)) (setq group-point (point)) (gnus-article-stop-animations) + (unless leave-hidden + (gnus-configure-windows 'group 'force)) (if temporary nil ;Nothing to do. (set-buffer buf) @@ -7350,8 +7353,6 @@ If FORCE (the prefix), also save the .newsrc file(s)." (if quit-config (gnus-handle-ephemeral-exit quit-config) (goto-char group-point) - (unless leave-hidden - (gnus-configure-windows 'group 'force)) ;; If gnus-group-buffer is already displayed, make sure we also move ;; the cursor in the window that displays it. (let ((win (get-buffer-window (current-buffer) 0))) @@ -12508,10 +12509,15 @@ save those articles instead." "Save parts matching TYPE to DIR. If REVERSE, save parts that do not match TYPE." (interactive - (list (read-string "Save parts of type: " - (or (car gnus-summary-save-parts-type-history) - gnus-summary-save-parts-default-mime) - 'gnus-summary-save-parts-type-history) + (list (completing-read "Save parts of type: " + (progn + (gnus-summary-select-article nil t) + (gnus-eval-in-buffer-window gnus-article-buffer + (delete-dups + (mapcar (lambda (h) + (mm-handle-media-type (cdr h))) + gnus-article-mime-handle-alist)))) + nil nil nil 'gnus-summary-save-parts-type-history) (setq gnus-summary-save-parts-last-directory (read-directory-name "Save to directory: " gnus-summary-save-parts-last-directory diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 89d5d120549..c411ec7deb6 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -2226,8 +2226,8 @@ Disabling the agent may result in noticeable loss of performance." :group 'gnus-start :type '(choice (function-item gnus) (function-item gnus-no-server) - (function-item gnus-slave) - (function-item gnus-slave-no-server))) + (function-item gnus-child) + (function-item gnus-child-no-server))) (declare-function gnus-group-get-new-news "gnus-group") @@ -2238,8 +2238,8 @@ Disabling the agent may result in noticeable loss of performance." :type '(choice (function-item gnus) (function-item gnus-group-get-new-news) (function-item gnus-no-server) - (function-item gnus-slave) - (function-item gnus-slave-no-server))) + (function-item gnus-child) + (function-item gnus-child-no-server))) (defcustom gnus-other-frame-parameters nil "Frame parameters used by `gnus-other-frame' to create a Gnus frame." @@ -2417,8 +2417,8 @@ such as a mark that says whether an article is stored in the cache (defvar gnus-article-buffer "*Article*") (defvar gnus-server-buffer "*Server*") -(defvar gnus-slave nil - "Whether this Gnus is a slave or not.") +(defvar gnus-child nil + "Whether this Gnus is a child or not.") (defvar gnus-batch-mode nil "Whether this Gnus is running in batch mode or not.") @@ -4034,13 +4034,20 @@ Allow completion over sensible values." ;;; User-level commands. ;;;###autoload +(defun gnus-child-no-server (&optional arg) + "Read network news as a child, without connecting to the local server." + (interactive "P") + (gnus-no-server arg t)) + +;;;###autoload (defun gnus-slave-no-server (&optional arg) - "Read network news as a slave, without connecting to the local server." + "Read network news as a child, without connecting to the local server." (interactive "P") (gnus-no-server arg t)) +(make-obsolete 'gnus-slave-no-server 'gnus-child-no-server "28.1") ;;;###autoload -(defun gnus-no-server (&optional arg slave) +(defun gnus-no-server (&optional arg child) "Read network news. If ARG is a positive number, Gnus will use that as the startup level. If ARG is nil, Gnus will be started at level 2. If ARG is non-nil @@ -4049,13 +4056,20 @@ an NNTP server to use. As opposed to `gnus', this command will not connect to the local server." (interactive "P") - (gnus-no-server-1 arg slave)) + (gnus-no-server-1 arg child)) + +;;;###autoload +(defun gnus-child (&optional arg) + "Read news as a child." + (interactive "P") + (gnus arg nil 'child)) ;;;###autoload (defun gnus-slave (&optional arg) - "Read news as a slave." + "Read news as a child." (interactive "P") - (gnus arg nil 'slave)) + (gnus arg nil 'child)) +(make-obsolete 'gnus-slave 'gnus-child "28.1") (defun gnus-delete-gnus-frame () "Delete gnus frame unless it is the only one. @@ -4116,7 +4130,7 @@ current display is used." (add-hook 'gnus-suspend-gnus-hook #'gnus-delete-gnus-frame))))) ;;;###autoload -(defun gnus (&optional arg dont-connect slave) +(defun gnus (&optional arg dont-connect child) "Read network news. If ARG is non-nil and a positive number, Gnus will use that as the startup level. If ARG is non-nil and not a positive number, Gnus will @@ -4131,7 +4145,7 @@ prompt the user for the name of an NNTP server to use." (message "You should compile Gnus") (sit-for 2)) (let ((gnus-action-message-log (list nil))) - (gnus-1 arg dont-connect slave) + (gnus-1 arg dont-connect child) (gnus-final-warning))) (declare-function debbugs-gnu "ext:debbugs-gnu" diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el index 02d90603b40..a5c82447926 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el @@ -1263,7 +1263,17 @@ If SEND-IF-FORCE, only send authinfo to the server if the "nntpd" pbuffer nntp-address nntp-port-number :type (cadr (assoc nntp-open-connection-function map)) :end-of-command "^\\([2345]\\|[.]\\).*\n" - :capability-command "HELP\r\n" + :capability-command + (lambda (greeting) + (if (and greeting + (string-match "Typhoon" greeting)) + ;; Certain versions of the Typhoon server + ;; doesn't understand the CAPABILITIES + ;; command, but includes the capability + ;; data in the HELP command instead. + "HELP\r\n" + ;; Use the correct command for everything else. + "CAPABILITIES\r\n")) :success "^3" :starttls-function (lambda (capabilities) diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el index 7f3dc4454ab..efbc0668553 100644 --- a/lisp/mail/emacsbug.el +++ b/lisp/mail/emacsbug.el @@ -208,7 +208,11 @@ This requires either the macOS \"open\" command, or the freedesktop ;;;###autoload (defun report-emacs-bug (topic &optional unused) "Report a bug in GNU Emacs. -Prompts for bug subject. Leaves you in a mail buffer." +Prompts for bug subject. Leaves you in a mail buffer. + +Already submitted bugs can be found in the Emacs bug tracker: + + https://debbugs.gnu.org/cgi/pkgreport.cgi?package=emacs;max-bugs=100;base-order=1;bug-rev=1" (declare (advertised-calling-convention (topic) "24.5")) (interactive "sBug Subject: ") ;; The syntax `version;' is preferred to `[version]' because the @@ -270,7 +274,7 @@ Prompts for bug subject. Leaves you in a mail buffer." 'face 'link 'help-echo (concat "mouse-2, RET: Follow this link") 'action (lambda (button) - (browse-url "https://debbugs.gnu.org/")) + (browse-url "https://debbugs.gnu.org/cgi/pkgreport.cgi?package=emacs;max-bugs=100;base-order=1;bug-rev=1")) 'follow-link t) (insert ". Please check that diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 2f6528de948..f4e3aa36c55 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -263,13 +263,17 @@ This list can be customized via `eww-suggest-uris'." (nreverse uris))) ;;;###autoload -(defun eww (url &optional arg) +(defun eww (url &optional arg buffer) "Fetch URL and render the page. If the input doesn't look like an URL or a domain name, the word(s) will be searched for via `eww-search-prefix'. If called with a prefix ARG, use a new buffer instead of reusing -the default EWW buffer." +the default EWW buffer. + +If BUFFER, the data to be rendered is in that buffer. In that +case, this function doesn't actually fetch URL. BUFFER will be +killed after rendering." (interactive (let* ((uris (eww-suggested-uris)) (prompt (concat "Enter URL or keywords" @@ -307,8 +311,12 @@ the default EWW buffer." (insert (format "Loading %s..." url)) (goto-char (point-min))) (let ((url-mime-accept-string eww-accept-content-types)) - (url-retrieve url #'eww-render - (list url nil (current-buffer))))) + (if buffer + (let ((eww-buffer (current-buffer))) + (with-current-buffer buffer + (eww-render nil url nil eww-buffer))) + (url-retrieve url #'eww-render + (list url nil (current-buffer)))))) (function-put 'eww 'browse-url-browser-kind 'internal) @@ -361,7 +369,19 @@ the default EWW buffer." (eww (concat "file://" (and (memq system-type '(windows-nt ms-dos)) "/") - (expand-file-name file)))) + (expand-file-name file)) + nil + ;; The file name may be a non-local Tramp file. The URL + ;; library doesn't understand these file names, so use the + ;; normal Emacs machinery to load the file. + (with-current-buffer (generate-new-buffer " *eww file*") + (set-buffer-multibyte nil) + (insert "Content-type: " (or (mailcap-extension-to-mime + (url-file-extension file)) + "application/octet-stream") + "\n\n") + (insert-file-contents file) + (current-buffer)))) ;;;###autoload (defun eww-search-words () @@ -1260,7 +1280,7 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (defun eww-tag-textarea (dom) (let ((start (point)) - (value (or (dom-attr dom 'value) "")) + (value (or (dom-text dom) "")) (lines (string-to-number (or (dom-attr dom 'rows) "10"))) (width (string-to-number (or (dom-attr dom 'cols) "10"))) end) @@ -1744,25 +1764,27 @@ If CHARSET is nil then use UTF-8." (insert ";; Auto-generated file; don't edit -*- mode: lisp-data -*-\n") (pp eww-bookmarks (current-buffer)))) -(defun eww-read-bookmarks () +(defun eww-read-bookmarks (&optional error-out) + "Read bookmarks from `eww-bookmarks'. +If ERROR-OUT, signal user-error if there are no bookmarks." (let ((file (expand-file-name "eww-bookmarks" eww-bookmarks-directory))) (setq eww-bookmarks (unless (zerop (or (file-attribute-size (file-attributes file)) 0)) (with-temp-buffer (insert-file-contents file) - (read (current-buffer))))))) + (read (current-buffer))))) + (when (and error-out (not eww-bookmarks)) + (user-error "No bookmarks are defined")))) ;;;###autoload (defun eww-list-bookmarks () "Display the bookmarks." (interactive) + (eww-read-bookmarks t) (pop-to-buffer "*eww bookmarks*") (eww-bookmark-prepare)) (defun eww-bookmark-prepare () - (eww-read-bookmarks) - (unless eww-bookmarks - (user-error "No bookmarks are defined")) (set-buffer (get-buffer-create "*eww bookmarks*")) (eww-bookmark-mode) (let* ((width (/ (window-width) 2)) @@ -1830,6 +1852,7 @@ If CHARSET is nil then use UTF-8." bookmark) (unless (get-buffer "*eww bookmarks*") (setq first t) + (eww-read-bookmarks t) (eww-bookmark-prepare)) (with-current-buffer (get-buffer "*eww bookmarks*") (when (and (not first) @@ -1848,6 +1871,7 @@ If CHARSET is nil then use UTF-8." bookmark) (unless (get-buffer "*eww bookmarks*") (setq first t) + (eww-read-bookmarks t) (eww-bookmark-prepare)) (with-current-buffer (get-buffer "*eww bookmarks*") (if first diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el index 1c371f59870..e86426d4664 100644 --- a/lisp/net/network-stream.el +++ b/lisp/net/network-stream.el @@ -139,7 +139,10 @@ writes. See `make-network-process' for details. :capability-command specifies a command used to query the HOST for its capabilities. For instance, for IMAP this should be - \"1 CAPABILITY\\r\\n\". + \"1 CAPABILITY\\r\\n\". This can either be a string (which will + then be sent verbatim to the server), or a function (called with + a single parameter; the \"greeting\" from the server when connecting), + and should return a string to send to the server. :starttls-function specifies a function for handling STARTTLS. This function should take one parameter, the response to the @@ -280,8 +283,11 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." :coding (plist-get parameters :coding))) (greeting (and (not (plist-get parameters :nogreeting)) (network-stream-get-response stream start eoc))) - (capabilities (network-stream-command stream capability-command - eo-capa)) + (capabilities + (network-stream-command + stream + (network-stream--capability-command capability-command greeting) + eo-capa)) (resulting-type 'plain) starttls-available starttls-command error) @@ -329,7 +335,10 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." ;; Requery capabilities for protocols that require it; i.e., ;; EHLO for SMTP. (when (plist-get parameters :always-query-capabilities) - (network-stream-command stream capability-command eo-capa))) + (network-stream-command + stream + (network-stream--capability-command capability-command greeting) + eo-capa))) (when (let ((response (network-stream-command stream starttls-command eoc))) (and response (string-match success-string response))) @@ -365,7 +374,10 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." host service)) ;; Re-get the capabilities, which may have now changed. (setq capabilities - (network-stream-command stream capability-command eo-capa)))) + (network-stream-command + stream + (network-stream--capability-command capability-command greeting) + eo-capa)))) ;; If TLS is mandatory, close the connection if it's unencrypted. (when (and require-tls @@ -428,7 +440,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." parameters) (require 'tls) (open-tls-stream name buffer host service))) - (eoc (plist-get parameters :end-of-command))) + (eoc (plist-get parameters :end-of-command)) + greeting) (if (plist-get parameters :nowait) (list stream nil nil 'tls) ;; Check certificate validity etc. @@ -440,17 +453,22 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." ;; openssl/gnutls-cli. (when (and (not (gnutls-available-p)) eoc) - (network-stream-get-response stream start eoc) + (setq greeting (network-stream-get-response stream start eoc)) (goto-char (point-min)) (when (re-search-forward eoc nil t) (goto-char (match-beginning 0)) (delete-region (point-min) (line-beginning-position)))) - (let ((capability-command (plist-get parameters :capability-command)) + (let ((capability-command + (plist-get parameters :capability-command)) (eo-capa (or (plist-get parameters :end-of-capability) eoc))) (list stream (network-stream-get-response stream start eoc) - (network-stream-command stream capability-command eo-capa) + (network-stream-command + stream + (network-stream--capability-command + capability-command greeting) + eo-capa) 'tls))))))) (defun network-stream-open-shell (name buffer host service parameters) @@ -464,21 +482,29 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (format-spec (plist-get parameters :shell-command) `((?s . ,host) - (?p . ,service))))))) + (?p . ,service)))))) + greeting) (when coding (if (consp coding) - (set-process-coding-system stream - (car coding) - (cdr coding)) (set-process-coding-system stream - coding - coding))) + (car coding) + (cdr coding)) + (set-process-coding-system stream + coding + coding))) (list stream - (network-stream-get-response stream start eoc) - (network-stream-command stream capability-command - (or (plist-get parameters :end-of-capability) - eoc)) + (setq greeting (network-stream-get-response stream start eoc)) + (network-stream-command + stream + (network-stream--capability-command capability-command greeting) + (or (plist-get parameters :end-of-capability) + eoc)) 'plain))) +(defun network-stream--capability-command (command greeting) + (if (functionp command) + (funcall command greeting) + command)) + (provide 'network-stream) ;;; network-stream.el ends here diff --git a/lisp/net/shr.el b/lisp/net/shr.el index a3f04968a27..ddd81127213 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -95,15 +95,31 @@ If nil, don't draw horizontal table lines." :type 'character) (defcustom shr-width nil - "Frame width to use for rendering. + "Window width to use for HTML rendering. May either be an integer specifying a fixed width in characters, -or nil, meaning that the full width of the window should be used. -If `shr-use-fonts' is set, the mean character width is used to -compute the pixel width, which is used instead." +or nil, meaning use the full width of the window. +If `shr-use-fonts' is set, the value is interpreted as a multiple +of the mean character width of the default face's font. + +Also see `shr-max-width'." :version "25.1" :type '(choice (integer :tag "Fixed width in characters") (const :tag "Use the width of the window" nil))) +(defcustom shr-max-width 120 + "Maximum text width to use for HTML rendering. +May either be an integer specifying a fixed width in characters, +or nil, meaning that there is no width limit. + +If `shr-use-fonts' is set, the value of this variable is +interpreted as a multiple of the mean character width of the +default face's font. + +If `shr-width' is non-nil, it overrides this variable." + :version "28.1" + :type '(choice (integer :tag "Fixed width in characters") + (const :tag "No width limit" nil))) + (defcustom shr-bullet "* " "Bullet used for unordered lists. Alternative suggestions are: @@ -267,30 +283,37 @@ DOM should be a parse tree as generated by (shr-table-separator-pixel-width (shr-string-pixel-width "-")) (shr-internal-bullet (cons shr-bullet (shr-string-pixel-width shr-bullet))) - (shr-internal-width (or (and shr-width - (if (not shr-use-fonts) - shr-width - (* shr-width (frame-char-width)))) - ;; We need to adjust the available - ;; width for when the user disables - ;; the fringes, which will cause the - ;; display engine usurp one column for - ;; the continuation glyph. - (if (not shr-use-fonts) - (- (window-body-width) 1 - (if (and (null shr-width) - (not (shr--have-one-fringe-p))) - 0 - 1)) - (- (window-body-width nil t) - (* 2 (frame-char-width)) - (if (and (null shr-width) - (not (shr--have-one-fringe-p))) - (* (frame-char-width) 2) - 0) - 1)))) + (shr-internal-width + (if shr-width + ;; Specified width; use it. + (if (not shr-use-fonts) + shr-width + (* shr-width (frame-char-width))) + ;; Compute the width based on the window width. We need to + ;; adjust the available width for when the user disables + ;; the fringes, which will cause the display engine usurp + ;; one column for the continuation glyph. + (if (not shr-use-fonts) + (- (window-body-width) 1 + (if (shr--have-one-fringe-p) + 1 + 0)) + (- (window-body-width nil t) + (* 2 (frame-char-width)) + (if (shr--have-one-fringe-p) + 0 + (* (frame-char-width) 2)) + 1)))) (max-specpdl-size max-specpdl-size) bidi-display-reordering) + ;; Adjust for max width specification. + (when (and shr-max-width + (not shr-width)) + (setq shr-internal-width + (min shr-internal-width + (if shr-use-fonts + (* shr-max-width (frame-char-width)) + shr-max-width)))) ;; If the window was hscrolled for some reason, shr-fill-lines ;; below will misbehave, because it silently assumes that it ;; starts with a non-hscrolled window (vertical-motion will move @@ -2576,12 +2599,28 @@ flags that control whether to collect or render objects." i)) (defun shr-max-columns (dom) - (let ((max 0)) + (let ((max 0) + (this 0) + (rowspans nil)) (dolist (row (dom-children dom)) (when (and (not (stringp row)) (eq (dom-tag row) 'tr)) - (setq max (max max (+ (shr-count row 'td) - (shr-count row 'th)))))) + (setq this 0) + (dolist (column (dom-children row)) + (when (and (not (stringp column)) + (memq (dom-tag column) '(td th))) + (setq this (+ 1 this (length rowspans))) + ;; We have a rowspan, which we emulate later in rendering + ;; by adding an extra column to the following rows. + (when-let* ((span (dom-attr column 'rowspan))) + (push (string-to-number span) rowspans)))) + (setq max (max max this))) + ;; Count down the rowspans in effect. + (let ((new nil)) + (dolist (span rowspans) + (when (> span 1) + (push (1- span) new))) + (setq rowspans new))) max)) (provide 'shr) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 25e4097a806..c1eb36e3405 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -55,7 +55,7 @@ It is used for TCP/IP devices." "When this method name is used, forward all calls to Android Debug Bridge.") ;;;###tramp-autoload -(defcustom tramp-adb-prompt "^[^#\\$]*[#\\$][[:space:]]" +(defcustom tramp-adb-prompt "^[^#$\n\r]*[#$][[:space:]]" "Regexp used as prompt in almquist shell." :type 'regexp :version "28.1" diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el index 9df51c1242a..b88ea0af82c 100644 --- a/lisp/progmodes/bug-reference.el +++ b/lisp/progmodes/bug-reference.el @@ -230,7 +230,7 @@ and apply it if applicable." (throw 'found t))))))))) (defvar bug-reference-setup-from-mail-alist - `((,(regexp-opt '("emacs" "auctex" "gnus") 'words) + `((,(regexp-opt '("emacs" "auctex" "gnus" "tramp" "orgmode") 'words) ,(regexp-opt '("@debbugs.gnu.org" "-devel@gnu.org" ;; List-Id of Gnus devel mailing list. "ding.gnus.org")) @@ -343,6 +343,65 @@ and set it if applicable." (push val header-values)))))) (bug-reference--maybe-setup-from-mail nil header-values))))))) +(defvar bug-reference-setup-from-irc-alist + `((,(concat "#" (regexp-opt '("emacs" "gnus" "org-mode" "rcirc" + "erc") 'words)) + "freenode" + "\\([Bb]ug ?#?\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)" + "https://debbugs.gnu.org/%s")) + "An alist for setting up `bug-reference-mode' in IRC modes. + +This takes action if `bug-reference-mode' is enabled in IRC +channels using one of Emacs' IRC clients (rcirc and ERC). +Currently, only rcirc is supported. + +Each element has the form + + (CHANNEL-REGEXP SERVER-REGEXP BUG-REGEXP URL-FORMAT) + +CHANNEL-REGEXP is a regexp matched against the current mail IRC +channel name. SERVER-REGEXP is matched against the IRC server +name. If any of those matches, BUG-REGEXP is set as +`bug-reference-bug-regexp' and URL-FORMAT is set as +`bug-reference-url-format'.") + +(defun bug-reference--maybe-setup-from-irc (channel server) + "Set up according to IRC CHANNEL or SERVER. +CHANNEL is an IRC channel name and SERVER is that channel's +server name. + +If any CHANNEL-REGEXP or SERVER-REGEXP of +`bug-reference-setup-from-irc-alist' matches CHANNEL or SERVER, +the corresponding BUG-REGEXP and URL-FORMAT are set." + (catch 'setup-done + (dolist (config bug-reference-setup-from-irc-alist) + (when (or + (and channel + (car config) + (string-match-p (car config) channel)) + (and server + (nth 1 config) + (string-match-p (car config) server))) + (setq-local bug-reference-bug-regexp (nth 2 config)) + (setq-local bug-reference-url-format (nth 3 config)) + (throw 'setup-done t))))) + +(defvar rcirc-target) +(defvar rcirc-server-buffer) +(defvar rcirc-server) + +(defun bug-reference-try-setup-from-rcirc () + "Try setting up `bug-reference-mode' based on rcirc channel and server. +Test each configuration in `bug-reference-setup-from-irc-alist' +and set it if applicable." + (when (derived-mode-p 'rcirc-mode) + (bug-reference--maybe-setup-from-irc + rcirc-target + (and rcirc-server-buffer + (buffer-live-p rcirc-server-buffer) + (with-current-buffer rcirc-server-buffer + rcirc-server))))) + (defun bug-reference--run-auto-setup () (when (or bug-reference-mode bug-reference-prog-mode) @@ -354,7 +413,8 @@ and set it if applicable." "Error during bug-reference auto-setup: %S" (catch 'setup (dolist (f (list #'bug-reference-try-setup-from-vc - #'bug-reference-try-setup-from-gnus)) + #'bug-reference-try-setup-from-gnus + #'bug-reference-try-setup-from-rcirc)) (when (funcall f) (throw 'setup t)))))))) diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el index 92c1ce89b8c..81bcd101fe4 100644 --- a/lisp/progmodes/cc-mode.el +++ b/lisp/progmodes/cc-mode.el @@ -2337,68 +2337,48 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") ;; line was fouled up by context fontification. (save-restriction (widen) - (let (new-beg new-end new-region case-fold-search string-fence-beg lim) - ;; Check how far back we need to extend the region where we reapply the - ;; string fence syntax-table properties. These must be in place for the - ;; coming fontification operations. - (save-excursion - (goto-char (if c-in-after-change-fontification - (min beg c-new-BEG) - beg)) - (setq lim (max (- (point) 500) (point-min))) - (while + (let (new-beg new-end new-region case-fold-search) + (c-save-buffer-state nil + ;; Temporarily reapply the string fence syntax-table properties. + (unwind-protect (progn - (skip-chars-backward "^\"" lim) - (or (bobp) (backward-char)) - (save-excursion - (eq (logand (skip-chars-backward "\\\\") 1) 1)))) - (setq string-fence-beg - (cond ((c-get-char-property (point) 'c-fl-syn-tab) - (point)) - (c-in-after-change-fontification - c-new-BEG) - (t beg))) - (c-save-buffer-state nil - ;; Temporarily reapply the string fence syntax-table properties. - (unwind-protect - (progn - (c-restore-string-fences) - (if (and c-in-after-change-fontification - (< beg c-new-END) (> end c-new-BEG)) - ;; Region and the latest after-change fontification region overlap. - ;; Determine the upper and lower bounds of our adjusted region - ;; separately. - (progn - (if (<= beg c-new-BEG) - (setq c-in-after-change-fontification nil)) - (setq new-beg - (if (and (>= beg (c-point 'bol c-new-BEG)) - (<= beg c-new-BEG)) - ;; Either jit-lock has accepted `c-new-BEG', or has - ;; (probably) extended the change region spuriously - ;; to BOL, which position likely has a - ;; syntactically different position. To ensure - ;; correct fontification, we start at `c-new-BEG', - ;; assuming any characters to the left of - ;; `c-new-BEG' on the line do not require - ;; fontification. - c-new-BEG - (setq new-region (c-before-context-fl-expand-region beg end) - new-end (cdr new-region)) - (car new-region))) - (setq new-end - (if (and (>= end (c-point 'bol c-new-END)) - (<= end c-new-END)) - c-new-END - (or new-end - (cdr (c-before-context-fl-expand-region beg end)))))) - ;; Context (etc.) fontification. - (setq new-region (c-before-context-fl-expand-region beg end) - new-beg (car new-region) new-end (cdr new-region))) - ;; Finally invoke font lock's functionality. - (funcall (default-value 'font-lock-fontify-region-function) - new-beg new-end verbose)) - (c-clear-string-fences))))))) + (c-restore-string-fences) + (if (and c-in-after-change-fontification + (< beg c-new-END) (> end c-new-BEG)) + ;; Region and the latest after-change fontification region overlap. + ;; Determine the upper and lower bounds of our adjusted region + ;; separately. + (progn + (if (<= beg c-new-BEG) + (setq c-in-after-change-fontification nil)) + (setq new-beg + (if (and (>= beg (c-point 'bol c-new-BEG)) + (<= beg c-new-BEG)) + ;; Either jit-lock has accepted `c-new-BEG', or has + ;; (probably) extended the change region spuriously + ;; to BOL, which position likely has a + ;; syntactically different position. To ensure + ;; correct fontification, we start at `c-new-BEG', + ;; assuming any characters to the left of + ;; `c-new-BEG' on the line do not require + ;; fontification. + c-new-BEG + (setq new-region (c-before-context-fl-expand-region beg end) + new-end (cdr new-region)) + (car new-region))) + (setq new-end + (if (and (>= end (c-point 'bol c-new-END)) + (<= end c-new-END)) + c-new-END + (or new-end + (cdr (c-before-context-fl-expand-region beg end)))))) + ;; Context (etc.) fontification. + (setq new-region (c-before-context-fl-expand-region beg end) + new-beg (car new-region) new-end (cdr new-region))) + ;; Finally invoke font lock's functionality. + (funcall (default-value 'font-lock-fontify-region-function) + new-beg new-end verbose)) + (c-clear-string-fences)))))) (defun c-after-font-lock-init () ;; Put on `font-lock-mode-hook'. This function ensures our after-change diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 67ce3dc7d95..db8e54b3323 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -91,6 +91,7 @@ ;;; Code: (require 'cl-generic) +(require 'seq) (eval-when-compile (require 'subr-x)) (defgroup project nil diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index 04f4bca166c..cee88cb4275 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -1581,7 +1581,8 @@ When `switch-to-buffer-obey-display-actions' is non-nil, (display-buffer-in-tab buffer (append alist '((inhibit-same-window . nil)))) (selected-window)) - 'tab))) + 'tab)) + nil "[other-tab]") (message "Display next command buffer in a new tab...")) (define-key tab-prefix-map "2" 'tab-new) diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index 669c24571f9..8532da1d1fb 100644 --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el @@ -702,15 +702,7 @@ should be shown to the user." ;; Treat everything like '300' nil)) (when redirect-uri - ;; Clean off any whitespace and/or <...> cruft. - (if (string-match "\\([^ \t]+\\)[ \t]" redirect-uri) - (setq redirect-uri (match-string 1 redirect-uri))) - (if (string-match "^<\\(.*\\)>$" redirect-uri) - (setq redirect-uri (match-string 1 redirect-uri))) - - ;; Some stupid sites (like sourceforge) send a - ;; non-fully-qualified URL (ie: /), which royally confuses - ;; the URL library. + ;; Handle relative redirect URIs. (if (not (string-match url-nonrelative-link redirect-uri)) ;; Be careful to use the real target URL, otherwise we may ;; compute the redirection relative to the URL of the proxy. @@ -1404,13 +1396,22 @@ The return value of this function is the retrieval buffer." (defun url-https-proxy-connect (connection) (setq url-http-after-change-function 'url-https-proxy-after-change-function) - (process-send-string connection (format (concat "CONNECT %s:%d HTTP/1.1\r\n" - "Host: %s\r\n" - "\r\n") - (url-host url-current-object) - (or (url-port url-current-object) - url-https-default-port) - (url-host url-current-object)))) + (process-send-string + connection + (format + (concat "CONNECT %s:%d HTTP/1.1\r\n" + "Host: %s\r\n" + (let ((proxy-auth (let ((url-basic-auth-storage + 'url-http-proxy-basic-auth-storage)) + (url-get-authentication url-http-proxy nil + 'any nil)))) + (and proxy-auth + (concat "Proxy-Authorization: " proxy-auth "\r\n"))) + "\r\n") + (url-host url-current-object) + (or (url-port url-current-object) + url-https-default-port) + (url-host url-current-object)))) (defun url-https-proxy-after-change-function (_st _nd _length) (let* ((process-buffer (current-buffer)) diff --git a/lisp/url/url-queue.el b/lisp/url/url-queue.el index ff18cf1fe40..46cdff0f724 100644 --- a/lisp/url/url-queue.el +++ b/lisp/url/url-queue.el @@ -123,17 +123,24 @@ The variable `url-queue-timeout' sets a timeout." (setq url-queue-progress-timer nil)))) (defun url-queue-callback-function (status job) - (setq url-queue (delq job url-queue)) - (when (and (eq (car status) :error) - (eq (cadr (cadr status)) 'connection-failed)) - ;; If we get a connection error, then flush all other jobs from - ;; the host from the queue. This particularly makes sense if the - ;; error really is a DNS resolver issue, which happens - ;; synchronously and totally halts Emacs. - (url-queue-remove-jobs-from-host - (plist-get (nthcdr 3 (cadr status)) :host))) - (url-queue-run-queue) - (apply (url-queue-callback job) (cons status (url-queue-cbargs job)))) + (let ((buffer (current-buffer))) + (setq url-queue (delq job url-queue)) + (when (and (eq (car status) :error) + (eq (cadr (cadr status)) 'connection-failed)) + ;; If we get a connection error, then flush all other jobs from + ;; the host from the queue. This particularly makes sense if the + ;; error really is a DNS resolver issue, which happens + ;; synchronously and totally halts Emacs. + (url-queue-remove-jobs-from-host + (plist-get (nthcdr 3 (cadr status)) :host))) + (url-queue-run-queue) + ;; Somehow something deep in the bowels in the URL library may + ;; have killed off the current buffer. So check that it's still + ;; alive before doing anything, and if not, just create a dummy + ;; buffer and do the callback anyway. + (unless (buffer-live-p buffer) + (set-buffer (generate-new-buffer " *temp*"))) + (apply (url-queue-callback job) (cons status (url-queue-cbargs job))))) (defun url-queue-remove-jobs-from-host (host) (let ((jobs nil)) diff --git a/lisp/windmove.el b/lisp/windmove.el index 341c739d924..65579600640 100644 --- a/lisp/windmove.el +++ b/lisp/windmove.el @@ -491,8 +491,8 @@ When `switch-to-buffer-obey-display-actions' is non-nil, (cons window type))) (lambda (old-window new-window) (when (window-live-p (if no-select old-window new-window)) - (select-window (if no-select old-window new-window)))))) - (message "[display-%s]" dir)) + (select-window (if no-select old-window new-window)))) + (format "[display-%s]" dir)))) ;;;###autoload (defun windmove-display-left (&optional arg) diff --git a/lisp/window.el b/lisp/window.el index 675aff041b1..f20940fa0ea 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -4021,7 +4021,8 @@ When `switch-to-buffer-obey-display-actions' is non-nil, (setq type 'window) (setq window (display-buffer-use-some-window buffer alist) type 'reuse)) - (cons window type)))) + (cons window type))) + nil "[other-window]") (message "Display next command buffer in a new window...")) (defun same-window-prefix () @@ -4039,7 +4040,8 @@ When `switch-to-buffer-obey-display-actions' is non-nil, (cons (or (display-buffer-same-window buffer alist) (display-buffer-use-some-window buffer alist)) - 'reuse))) + 'reuse)) + nil "[same-window]") (message "Display next command buffer in the same window...")) ;; This should probably return non-nil when the selected window is part @@ -8616,14 +8618,16 @@ documentation for additional customization information." (list (read-buffer-to-switch "Switch to buffer in other frame: "))) (pop-to-buffer buffer-or-name display-buffer--other-frame-action norecord)) -(defun display-buffer-override-next-command (pre-function &optional post-function) +(defun display-buffer-override-next-command (pre-function &optional post-function echo) "Set `display-buffer-overriding-action' for the next command. `pre-function' is called to prepare the window where the buffer should be displayed. This function takes two arguments `buffer' and `alist', and should return a cons with the displayed window and its type. See the meaning of these values in `window--display-buffer'. Optional `post-function' is called after the buffer is displayed in the -window; the function takes two arguments: an old and new window." +window; the function takes two arguments: an old and new window. +Optional string argument `echo' can be used to add a prefix to the +command echo keystrokes that should describe the current prefix state." (let* ((old-window (or (minibuffer-selected-window) (selected-window))) (new-window nil) (minibuffer-depth (minibuffer-depth)) @@ -8641,11 +8645,13 @@ window; the function takes two arguments: an old and new window." (setq post-function nil) new-window)))) (command this-command) + (echofun (when echo (lambda () echo))) (exitfun (lambda () (setcar display-buffer-overriding-action (delq action (car display-buffer-overriding-action))) (remove-hook 'post-command-hook clearfun) + (remove-hook 'prefix-command-echo-keystrokes-functions echofun) (when (functionp post-function) (funcall post-function old-window new-window))))) (fset clearfun @@ -8661,6 +8667,8 @@ window; the function takes two arguments: an old and new window." ;; Reset display-buffer-overriding-action ;; after the next command finishes (add-hook 'post-command-hook clearfun) + (when echofun + (add-hook 'prefix-command-echo-keystrokes-functions echofun)) (push action (car display-buffer-overriding-action)))) diff --git a/src/image.c b/src/image.c index c8a192aaaf1..e7e0a93313b 100644 --- a/src/image.c +++ b/src/image.c @@ -8274,7 +8274,10 @@ gif_load (struct frame *f, struct image *img) rc = DGifSlurp (gif); if (rc == GIF_ERROR || gif->ImageCount <= 0) { - image_error ("Error reading `%s'", img->spec); + if (NILP (specified_data)) + image_error ("Error reading `%s'", img->spec); + else + image_error ("Error reading GIF data"); gif_close (gif, NULL); return 0; } |