summaryrefslogtreecommitdiff
path: root/lisp/net
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/net')
-rw-r--r--lisp/net/ange-ftp.el26
-rw-r--r--lisp/net/browse-url.el16
-rw-r--r--lisp/net/dbus.el22
-rw-r--r--lisp/net/dns.el23
-rw-r--r--lisp/net/eudc-bob.el3
-rw-r--r--lisp/net/eudc-export.el3
-rw-r--r--lisp/net/eudc-hotlist.el3
-rw-r--r--lisp/net/eudc-vars.el100
-rw-r--r--lisp/net/eudc.el74
-rw-r--r--lisp/net/eudcb-bbdb.el3
-rw-r--r--lisp/net/eudcb-ldap.el32
-rw-r--r--lisp/net/eudcb-mab.el2
-rw-r--r--lisp/net/eudcb-ph.el3
-rw-r--r--lisp/net/eww.el1297
-rw-r--r--lisp/net/gnutls.el17
-rw-r--r--lisp/net/ldap.el136
-rw-r--r--lisp/net/network-stream.el31
-rw-r--r--lisp/net/newst-backend.el486
-rw-r--r--lisp/net/newst-plainview.el1
-rw-r--r--lisp/net/newst-reader.el93
-rw-r--r--lisp/net/newst-ticker.el9
-rw-r--r--lisp/net/newst-treeview.el374
-rw-r--r--lisp/net/newsticker.el3
-rw-r--r--lisp/net/nsm.el502
-rw-r--r--lisp/net/ntlm.el38
-rw-r--r--lisp/net/rcirc.el302
-rw-r--r--lisp/net/shr.el745
-rw-r--r--lisp/net/tramp-sh.el59
-rw-r--r--lisp/net/tramp.el2
29 files changed, 3072 insertions, 1333 deletions
diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el
index d124027ea72..52153ad8322 100644
--- a/lisp/net/ange-ftp.el
+++ b/lisp/net/ange-ftp.el
@@ -1536,8 +1536,8 @@ then kill the related FTP process."
(signal 'file-error
(list "Opening directory"
(if (file-exists-p directory)
- "not a directory"
- "no such file or directory")
+ "Not a directory"
+ "No such file or directory")
directory))))
;;;; ------------------------------------------------------------
@@ -2831,16 +2831,24 @@ match subdirectories as well.")
files ange-ftp-files-hashtable)))
(defun ange-ftp-switches-ok (switches)
- "Return SWITCHES (a string) if suitable for our use."
+ "Return SWITCHES (a string) if suitable for use with ls over ftp."
(and (stringp switches)
- ;; We allow the A switch, which lists all files except "." and
- ;; "..". This is OK because we manually insert these entries
- ;; in the hash table.
+ ;; We allow the --almost-all switch, which lists all files
+ ;; except "." and "..". This is OK because we manually
+ ;; insert these entries in the hash table.
(string-match
- "--\\(almost-\\)?all\\>\\|\\(\\`\\| \\)-[[:alpha:]]*[aA]" switches)
+ "--\\(almost-\\)?all\\>\\|\\(\\`\\| \\)-[[:alpha:]]*[aA]"
+ switches)
+ ;; Disallow other long flags except --(almost-)all.
+ (not (string-match "\\(\\`\\| \\)--\\w+"
+ (replace-regexp-in-string
+ "--\\(almost-\\)?all\\>" ""
+ switches)))
+ ;; Must include 'l'.
(string-match "\\(\\`\\| \\)-[[:alpha:]]*l" switches)
+ ;; Disallow recursive flag.
(not (string-match
- "--recursive\\>\\|\\(\\`\\| \\)-[[:alpha:]]*R" switches))
+ "\\(\\`\\| \\)-[[:alpha:]]*R" switches))
switches))
(defun ange-ftp-get-files (directory &optional no-error)
@@ -3656,7 +3664,7 @@ so return the size on the remote host exactly. See RFC 3659."
(or (file-exists-p filename)
(signal 'file-error
- (list "Copy file" "no such file or directory" filename)))
+ (list "Copy file" "No such file or directory" filename)))
;; canonicalize newname if a directory.
(if (file-directory-p newname)
diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el
index e6ae0d7df06..42fb9549255 100644
--- a/lisp/net/browse-url.el
+++ b/lisp/net/browse-url.el
@@ -1343,16 +1343,12 @@ used instead of `browse-url-new-window-flag'."
"newwin\n"
"goto\n")
url "\n")
- (let ((umask (default-file-modes)))
- (unwind-protect
- (progn
- (set-default-file-modes ?\700)
- (if (file-exists-p
- (setq pidfile (format "/tmp/Mosaic.%d" pid)))
- (delete-file pidfile))
- ;; http://debbugs.gnu.org/17428. Use O_EXCL.
- (write-region nil nil pidfile nil 'silent nil 'excl))
- (set-default-file-modes umask))))
+ (with-file-modes ?\700
+ (if (file-exists-p
+ (setq pidfile (format "/tmp/Mosaic.%d" pid)))
+ (delete-file pidfile))
+ ;; http://debbugs.gnu.org/17428. Use O_EXCL.
+ (write-region nil nil pidfile nil 'silent nil 'excl)))
;; Send signal SIGUSR to Mosaic
(message "Signaling Mosaic...")
(signal-process pid 'SIGUSR1)
diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el
index b6ce8c5dac8..bbce300af40 100644
--- a/lisp/net/dbus.el
+++ b/lisp/net/dbus.el
@@ -544,6 +544,10 @@ placed in the queue.
`:already-owner': Service is already the primary owner."
+ ;; Add Peer handler.
+ (dbus-register-method
+ bus service nil dbus-interface-peer "Ping" 'dbus-peer-handler 'dont-register)
+
;; Add ObjectManager handler.
(dbus-register-method
bus service nil dbus-interface-objectmanager "GetManagedObjects"
@@ -1151,6 +1155,22 @@ apply
bus service dbus-path-dbus dbus-interface-peer "Ping")))
(dbus-error nil)))
+(defun dbus-peer-handler ()
+ "Default handler for the \"org.freedesktop.DBus.Peer\" interface.
+It will be registered for all objects created by `dbus-register-service'."
+ (let* ((last-input-event last-input-event)
+ (method (dbus-event-member-name last-input-event)))
+ (cond
+ ;; "Ping" does not return an output parameter.
+ ((string-equal method "Ping")
+ :ignore)
+ ;; "GetMachineId" returns "s".
+ ((string-equal method "GetMachineId")
+ (signal
+ 'dbus-error
+ (list
+ (format "%s.GetMachineId not implemented" dbus-interface-peer)))))))
+
;;; D-Bus introspection.
@@ -1672,7 +1692,7 @@ and \"org.freedesktop.DBus.Properties.GetAll\", which is slow."
(defun dbus-managed-objects-handler ()
"Default handler for the \"org.freedesktop.DBus.ObjectManager\" interface.
-It will be registered for all objects created by `dbus-register-method'."
+It will be registered for all objects created by `dbus-register-service'."
(let* ((last-input-event last-input-event)
(bus (dbus-event-bus-name last-input-event))
(path (dbus-event-path-name last-input-event)))
diff --git a/lisp/net/dns.el b/lisp/net/dns.el
index e2e55b84c76..ba6523f6f5f 100644
--- a/lisp/net/dns.el
+++ b/lisp/net/dns.el
@@ -31,6 +31,12 @@
"List of DNS servers to query.
If nil, /etc/resolv.conf and nslookup will be consulted.")
+(defvar dns-servers-valid-for-interfaces nil
+ "The return value of `network-interface-list' when `dns-servers' was set.
+If the set of network interfaces and/or their IP addresses
+change, then presumably the list of DNS servers needs to be
+updated. Set this variable to t to disable the check.")
+
;;; Internal code:
(defvar dns-query-types
@@ -297,6 +303,17 @@ If TCP-P, the first two bytes of the package with be the length field."
(t string)))
(goto-char point))))
+(declare-function network-interface-list "process.c")
+
+(defun dns-servers-up-to-date-p ()
+ "Return false if we need to recheck the list of DNS servers."
+ (and dns-servers
+ (or (eq dns-servers-valid-for-interfaces t)
+ ;; `network-interface-list' was introduced in Emacs 22.1.
+ (not (fboundp 'network-interface-list))
+ (equal dns-servers-valid-for-interfaces
+ (network-interface-list)))))
+
(defun dns-set-servers ()
"Set `dns-servers' to a list of DNS servers or nil if none are found.
Parses \"/etc/resolv.conf\" or calls \"nslookup\"."
@@ -314,7 +331,9 @@ Parses \"/etc/resolv.conf\" or calls \"nslookup\"."
(goto-char (point-min))
(re-search-forward
"^Address:[ \t]*\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" nil t)
- (setq dns-servers (list (match-string 1)))))))
+ (setq dns-servers (list (match-string 1))))))
+ (when (fboundp 'network-interface-list)
+ (setq dns-servers-valid-for-interfaces (network-interface-list))))
(defun dns-read-txt (string)
(if (> (length string) 1)
@@ -378,7 +397,7 @@ Parses \"/etc/resolv.conf\" or calls \"nslookup\"."
If FULLP, return the entire record returned.
If REVERSEP, look up an IP address."
(setq type (or type 'A))
- (unless dns-servers
+ (unless (dns-servers-up-to-date-p)
(dns-set-servers))
(when reversep
diff --git a/lisp/net/eudc-bob.el b/lisp/net/eudc-bob.el
index 622ea72d021..f01f671de9e 100644
--- a/lisp/net/eudc-bob.el
+++ b/lisp/net/eudc-bob.el
@@ -3,7 +3,8 @@
;; Copyright (C) 1999-2015 Free Software Foundation, Inc.
;; Author: Oscar Figueiredo <oscar@cpe.fr>
-;; Maintainer: Pavel Janík <Pavel@Janik.cz>
+;; Pavel Janík <Pavel@Janik.cz>
+;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org>
;; Keywords: comm
;; Package: eudc
diff --git a/lisp/net/eudc-export.el b/lisp/net/eudc-export.el
index bbdb294da7f..0e54d841d57 100644
--- a/lisp/net/eudc-export.el
+++ b/lisp/net/eudc-export.el
@@ -3,7 +3,8 @@
;; Copyright (C) 1998-2015 Free Software Foundation, Inc.
;; Author: Oscar Figueiredo <oscar@cpe.fr>
-;; Maintainer: Pavel Janík <Pavel@Janik.cz>
+;; Pavel Janík <Pavel@Janik.cz>
+;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org>
;; Keywords: comm
;; Package: eudc
diff --git a/lisp/net/eudc-hotlist.el b/lisp/net/eudc-hotlist.el
index b3c9a6db0d5..7416ad090eb 100644
--- a/lisp/net/eudc-hotlist.el
+++ b/lisp/net/eudc-hotlist.el
@@ -3,7 +3,8 @@
;; Copyright (C) 1998-2015 Free Software Foundation, Inc.
;; Author: Oscar Figueiredo <oscar@cpe.fr>
-;; Maintainer: Pavel Janík <Pavel@Janik.cz>
+;; Pavel Janík <Pavel@Janik.cz>
+;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org>
;; Keywords: comm
;; Package: eudc
diff --git a/lisp/net/eudc-vars.el b/lisp/net/eudc-vars.el
index 6bc0337f958..36a583daa4d 100644
--- a/lisp/net/eudc-vars.el
+++ b/lisp/net/eudc-vars.el
@@ -3,7 +3,8 @@
;; Copyright (C) 1998-2015 Free Software Foundation, Inc.
;; Author: Oscar Figueiredo <oscar@cpe.fr>
-;; Maintainer: Pavel Janík <Pavel@Janik.cz>
+;; Pavel Janík <Pavel@Janik.cz>
+;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org>
;; Keywords: comm
;; Package: eudc
@@ -41,14 +42,36 @@
"The name or IP address of the directory server.
A port number may be specified by appending a colon and a
number to the name of the server. Use `localhost' if the directory
-server resides on your computer (BBDB backend)."
- :type '(choice (string :tag "Server") (const :tag "None" nil))
- :group 'eudc)
+server resides on your computer (BBDB backend).
+
+To specify multiple servers, customize eudc-server-hotlist
+instead."
+ :type '(choice (string :tag "Server") (const :tag "None" nil)))
;; Known protocols (used in completion)
;; Not to be mistaken with `eudc-supported-protocols'
(defvar eudc-known-protocols '(bbdb ph ldap))
+(defcustom eudc-server-hotlist nil
+ "Directory servers to query.
+This is an alist of the form (SERVER . PROTOCOL). SERVER is the
+host name or URI of the server, PROTOCOL is a symbol representing
+the EUDC backend with which to access the server.
+
+The BBDB backend ignores SERVER; `localhost' can be used as a
+placeholder string."
+ :tag "Directory Servers to Query"
+ :type `(repeat (cons :tag "Directory Server"
+ (string :tag "Server Host Name or URI")
+ (choice :tag "Protocol"
+ :menu-tag "Protocol"
+ ,@(mapcar (lambda (s)
+ (list 'const
+ ':tag (symbol-name s) s))
+ eudc-known-protocols)
+ (const :tag "None" nil))))
+ :version "25.1")
+
(defvar eudc-supported-protocols nil
"Protocols currently supported by EUDC.
This variable is updated when protocol-specific libraries
@@ -61,15 +84,13 @@ Supported protocols are specified by `eudc-supported-protocols'."
,@(mapcar (lambda (s)
(list 'const ':tag (symbol-name s) s))
eudc-known-protocols)
- (const :tag "None" nil))
- :group 'eudc)
+ (const :tag "None" nil)))
(defcustom eudc-strict-return-matches t
"Ignore or allow entries not containing all requested return attributes.
If non-nil, such entries are ignored."
- :type 'boolean
- :group 'eudc)
+ :type 'boolean)
(defcustom eudc-default-return-attributes nil
"A list of default attributes to extract from directory entries.
@@ -82,8 +103,7 @@ server."
(repeat :menu-tag "Attribute list"
:tag "Attribute name"
:value (nil)
- (symbol :tag "Attribute name")))
- :group 'eudc)
+ (symbol :tag "Attribute name"))))
(defcustom eudc-multiple-match-handling-method 'select
"What to do when multiple entries match an inline expansion query.
@@ -102,8 +122,7 @@ Possible values are:
(const :menu-tag "Abort Operation"
:tag "Abort Operation" abort)
(const :menu-tag "Default (Use First)"
- :tag "Default (Use First)" nil))
- :group 'eudc)
+ :tag "Default (Use First)" nil)))
(defcustom eudc-duplicate-attribute-handling-method '((email . duplicate))
"A method to handle entries containing duplicate attributes.
@@ -130,10 +149,10 @@ different values."
(const :menu-tag "List" list)
(const :menu-tag "First" first)
(const :menu-tag "Concat" concat)
- (const :menu-tag "Duplicate" duplicate)))))
- :group 'eudc)
+ (const :menu-tag "Duplicate" duplicate))))))
-(defcustom eudc-inline-query-format '((name)
+(defcustom eudc-inline-query-format '((email)
+ (firstname)
(firstname name))
"Format of an inline expansion query.
This is a list of FORMATs. A FORMAT is itself a list of one or more
@@ -160,14 +179,16 @@ must be set in a protocol/server-local fashion, see `eudc-server-set' and
(const :menu-tag "Email Address" :tag "Email Address" email)
(const :menu-tag "Phone" :tag "Phone" phone)
(symbol :menu-tag "Other" :tag "Attribute name"))))
- :group 'eudc)
+ :version "25.1")
-(defcustom eudc-expansion-overwrites-query t
+;; Default to nil so that the most common use of eudc-expand-inline,
+;; where replace is nil, does not affect the kill ring.
+(defcustom eudc-expansion-overwrites-query nil
"If non-nil, expanding a query overwrites the query string."
:type 'boolean
- :group 'eudc)
+ :version "25.1")
-(defcustom eudc-inline-expansion-format '("%s" email)
+(defcustom eudc-inline-expansion-format '("%s %s <%s>" firstname name email)
"A list specifying the format of the expansion of inline queries.
This variable controls what `eudc-expand-inline' actually inserts in
the buffer. First element is a string passed to `format'. Remaining
@@ -185,7 +206,7 @@ are passed as additional arguments to `format'."
(const :menu-tag "Phone" :tag "Phone" phone)
(symbol :menu-tag "Other")
(symbol :tag "Attribute name"))))
- :group 'eudc)
+ :version "25.1")
(defcustom eudc-inline-expansion-servers 'server-then-hotlist
"Which servers to contact for the expansion of inline queries.
@@ -198,8 +219,7 @@ Possible values are:
:menu-tag "Servers"
(const :menu-tag "Current server" current-server)
(const :menu-tag "Servers in the hotlist" hotlist)
- (const :menu-tag "Current server then hotlist" server-then-hotlist))
- :group 'eudc)
+ (const :menu-tag "Current server then hotlist" server-then-hotlist)))
(defcustom eudc-max-servers-to-query nil
"Maximum number of servers to query for an inline expansion.
@@ -213,8 +233,7 @@ If nil, query all servers available from `eudc-inline-expansion-servers'."
(const :menu-tag "3" 3)
(const :menu-tag "4" 4)
(const :menu-tag "5" 5)
- (integer :menu-tag "Set"))
- :group 'eudc)
+ (integer :menu-tag "Set")))
(defcustom eudc-query-form-attributes '(name firstname email phone)
"A list of attributes presented in the query form."
@@ -226,8 +245,7 @@ If nil, query all servers available from `eudc-inline-expansion-servers'."
(const :menu-tag "Surname" :tag "Surname" name)
(const :menu-tag "Email Address" :tag "Email Address" email)
(const :menu-tag "Phone" :tag "Phone" phone)
- (symbol :menu-tag "Other" :tag "Attribute name")))
- :group 'eudc)
+ (symbol :menu-tag "Other" :tag "Attribute name"))))
(defcustom eudc-user-attribute-names-alist '((url . "URL")
(callsign . "HAM Call Sign")
@@ -257,15 +275,13 @@ at `_' characters and capitalizing the individual words."
:tag "User-defined Names of Directory Attributes"
:type '(repeat (cons :tag "Field"
(symbol :tag "Directory attribute")
- (string :tag "User friendly name ")))
- :group 'eudc)
+ (string :tag "User friendly name "))))
(defcustom eudc-use-raw-directory-names nil
"If non-nil, use attributes names as defined in the directory.
Otherwise, directory query/response forms display the user attribute
names defined in `eudc-user-attribute-names-alist'."
- :type 'boolean
- :group 'eudc)
+ :type 'boolean)
(defcustom eudc-attribute-display-method-alist nil
"An alist specifying methods to display attribute values.
@@ -277,8 +293,7 @@ attribute values for display."
:tag "Attribute Decoding Functions"
:type '(repeat (cons :tag "Attribute"
(symbol :tag "Name")
- (symbol :tag "Display Function")))
- :group 'eudc)
+ (symbol :tag "Display Function"))))
(defcustom eudc-external-viewers '(("ImageMagick" "display" "-")
("ShowAudio" "showaudio"))
@@ -295,18 +310,15 @@ arguments that should be passed to the program."
(repeat
:tag "Arguments"
:inline t
- (string :tag "Argument"))))
- :group 'eudc)
+ (string :tag "Argument")))))
(defcustom eudc-options-file "~/.eudc-options"
"A file where the `servers' hotlist is stored."
- :type '(file :Tag "File Name:")
- :group 'eudc)
+ :type '(file :Tag "File Name:"))
(defcustom eudc-mode-hook nil
"Normal hook run on entry to EUDC mode."
- :type '(repeat (sexp :tag "Hook definition"))
- :group 'eudc)
+ :type 'hook)
;;}}}
@@ -341,8 +353,7 @@ BBDB fields. SPECs are sexps which are evaluated:
:tag "BBDB to PH Field Name Mapping"
:type '(repeat (cons :tag "Field Name"
(symbol :tag "BBDB Field")
- (sexp :tag "Conversion Spec")))
- :group 'eudc-ph)
+ (sexp :tag "Conversion Spec"))))
;;}}}
@@ -376,8 +387,7 @@ BBDB fields. SPECs are sexps which are evaluated:
:tag "BBDB to LDAP Attribute Names Mapping"
:type '(repeat (cons :tag "Field Name"
(symbol :tag "BBDB Field")
- (sexp :tag "Conversion Spec")))
- :group 'eudc-ldap)
+ (sexp :tag "Conversion Spec"))))
;;}}}
@@ -391,14 +401,12 @@ BBDB fields. SPECs are sexps which are evaluated:
"If non-nil, BBDB address and phone locations are used as attribute names.
This has no effect on queries (you can't search for a specific location)
but influences the way records are displayed."
- :type 'boolean
- :group 'eudc-bbdb)
+ :type 'boolean)
(defcustom eudc-bbdb-enable-substring-matches t
"If non-nil, authorize substring match in the same way BBDB does.
Otherwise records must match queries exactly."
- :type 'boolean
- :group 'eudc-bbdb)
+ :type 'boolean)
;;}}}
diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el
index 0f2fc0be7bd..cf5d13fce88 100644
--- a/lisp/net/eudc.el
+++ b/lisp/net/eudc.el
@@ -3,7 +3,8 @@
;; Copyright (C) 1998-2015 Free Software Foundation, Inc.
;; Author: Oscar Figueiredo <oscar@cpe.fr>
-;; Maintainer: Pavel Janík <Pavel@Janik.cz>
+;; Pavel Janík <Pavel@Janik.cz>
+;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org>
;; Keywords: comm
;; This file is part of GNU Emacs.
@@ -76,10 +77,6 @@
(defvar mode-popup-menu)
-;; List of known servers
-;; Alist of (SERVER . PROTOCOL)
-(defvar eudc-server-hotlist nil)
-
;; List of variables that have server- or protocol-local bindings
(defvar eudc-local-vars nil)
@@ -688,7 +685,8 @@ server for future sessions."
(cons (symbol-name elt)
elt))
eudc-known-protocols)))))
- (unless (or (member protocol
+ (unless (or (null protocol)
+ (member protocol
eudc-supported-protocols)
(load (concat "eudcb-" (symbol-name protocol)) t))
(error "Unsupported protocol: %s" protocol))
@@ -766,7 +764,6 @@ otherwise a list of symbols is returned."
format (cdr format)))
;; If the same attribute appears more than once, merge
;; the corresponding values
- (setq query-alist (nreverse query-alist))
(while query-alist
(setq key (eudc-caar query-alist)
val (eudc-cdar query-alist)
@@ -812,19 +809,29 @@ If REPLACE is non-nil, then this expansion replaces the name in the buffer.
Multiple servers can be tried with the same query until one finds a match,
see `eudc-inline-expansion-servers'"
(interactive)
- (if (memq eudc-inline-expansion-servers
- '(current-server server-then-hotlist))
- (or eudc-server
- (call-interactively 'eudc-set-server))
+ (cond
+ ((eq eudc-inline-expansion-servers 'current-server)
+ (or eudc-server
+ (call-interactively 'eudc-set-server)))
+ ((eq eudc-inline-expansion-servers 'server-then-hotlist)
+ (or eudc-server
+ ;; Allow server to be nil if hotlist is set.
+ eudc-server-hotlist
+ (call-interactively 'eudc-set-server)))
+ ((eq eudc-inline-expansion-servers 'hotlist)
(or eudc-server-hotlist
(error "No server in the hotlist")))
+ (t
+ (error "Wrong value for `eudc-inline-expansion-servers': %S"
+ eudc-inline-expansion-servers)))
(let* ((end (point))
(beg (save-excursion
(if (re-search-backward "\\([:,]\\|^\\)[ \t]*"
(point-at-bol) 'move)
(goto-char (match-end 0)))
(point)))
- (query-words (split-string (buffer-substring beg end) "[ \t]+"))
+ (query-words (split-string (buffer-substring-no-properties beg end)
+ "[ \t]+"))
query-formats
response
response-string
@@ -840,18 +847,17 @@ see `eudc-inline-expansion-servers'"
((eq eudc-inline-expansion-servers 'hotlist)
eudc-server-hotlist)
((eq eudc-inline-expansion-servers 'server-then-hotlist)
- (cons (cons eudc-server eudc-protocol)
- (delete (cons eudc-server eudc-protocol) servers)))
+ (if eudc-server
+ (cons (cons eudc-server eudc-protocol)
+ (delete (cons eudc-server eudc-protocol) servers))
+ eudc-server-hotlist))
((eq eudc-inline-expansion-servers 'current-server)
- (list (cons eudc-server eudc-protocol)))
- (t
- (error "Wrong value for `eudc-inline-expansion-servers': %S"
- eudc-inline-expansion-servers))))
+ (list (cons eudc-server eudc-protocol)))))
(if (and eudc-max-servers-to-query
(> (length servers) eudc-max-servers-to-query))
(setcdr (nthcdr (1- eudc-max-servers-to-query) servers) nil))
- (condition-case signal
+ (unwind-protect
(progn
(setq response
(catch 'found
@@ -887,14 +893,15 @@ see `eudc-inline-expansion-servers'"
;; Process response through eudc-inline-expansion-format
(while response
- (setq response-string (apply 'format
- (car eudc-inline-expansion-format)
- (mapcar (function
- (lambda (field)
- (or (cdr (assq field (car response)))
- "")))
- (eudc-translate-attribute-list
- (cdr eudc-inline-expansion-format)))))
+ (setq response-string
+ (apply 'format
+ (car eudc-inline-expansion-format)
+ (mapcar (function
+ (lambda (field)
+ (or (cdr (assq field (car response)))
+ "")))
+ (eudc-translate-attribute-list
+ (cdr eudc-inline-expansion-format)))))
(if (> (length response-string) 0)
(setq response-strings
(cons response-string response-strings)))
@@ -916,15 +923,10 @@ see `eudc-inline-expansion-servers'"
(delete-region beg end)
(insert (mapconcat 'identity response-strings ", ")))
((eq eudc-multiple-match-handling-method 'abort)
- (error "There is more than one match for the query"))))
- (or (and (equal eudc-server eudc-former-server)
- (equal eudc-protocol eudc-former-protocol))
- (eudc-set-server eudc-former-server eudc-former-protocol t)))
- (error
- (or (and (equal eudc-server eudc-former-server)
- (equal eudc-protocol eudc-former-protocol))
- (eudc-set-server eudc-former-server eudc-former-protocol t))
- (signal (car signal) (cdr signal))))))
+ (error "There is more than one match for the query")))))
+ (or (and (equal eudc-server eudc-former-server)
+ (equal eudc-protocol eudc-former-protocol))
+ (eudc-set-server eudc-former-server eudc-former-protocol t)))))
;;;###autoload
(defun eudc-query-form (&optional get-fields-from-server)
diff --git a/lisp/net/eudcb-bbdb.el b/lisp/net/eudcb-bbdb.el
index 0400e5b5bb4..5be2bec0c5d 100644
--- a/lisp/net/eudcb-bbdb.el
+++ b/lisp/net/eudcb-bbdb.el
@@ -3,7 +3,8 @@
;; Copyright (C) 1998-2015 Free Software Foundation, Inc.
;; Author: Oscar Figueiredo <oscar@cpe.fr>
-;; Maintainer: Pavel Janík <Pavel@Janik.cz>
+;; Pavel Janík <Pavel@Janik.cz>
+;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org>
;; Keywords: comm
;; Package: eudc
diff --git a/lisp/net/eudcb-ldap.el b/lisp/net/eudcb-ldap.el
index 4c9b2490ee3..1d426a7b7b0 100644
--- a/lisp/net/eudcb-ldap.el
+++ b/lisp/net/eudcb-ldap.el
@@ -3,7 +3,8 @@
;; Copyright (C) 1998-2015 Free Software Foundation, Inc.
;; Author: Oscar Figueiredo <oscar@cpe.fr>
-;; Maintainer: Pavel Janík <Pavel@Janik.cz>
+;; Pavel Janík <Pavel@Janik.cz>
+;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org>
;; Keywords: comm
;; Package: eudc
@@ -70,16 +71,17 @@
("mail" . eudc-display-mail)
("url" . eudc-display-url))
'ldap)
-(eudc-protocol-set 'eudc-switch-to-server-hook
- '(eudc-ldap-check-base)
- 'ldap)
(defun eudc-ldap-cleanup-record-simple (record)
"Do some cleanup in a RECORD to make it suitable for EUDC."
(mapcar
(function
(lambda (field)
- (cons (intern (car field))
+ ;; Some servers return case-sensitive names (e.g. givenName
+ ;; instead of givenname); downcase the field's name so that it
+ ;; can be matched against
+ ;; eudc-ldap-attributes-translation-alist.
+ (cons (intern (downcase (car field)))
(if (cdr (cdr field))
(cdr field)
(car (cdr field))))))
@@ -95,7 +97,7 @@
(mapcar
(function
(lambda (field)
- (let ((name (intern (car field)))
+ (let ((name (intern (downcase (car field))))
(value (cdr field)))
(if (memq name '(postaladdress registeredaddress))
(setq value (mapcar 'eudc-filter-$ value)))
@@ -170,14 +172,16 @@ attribute names are returned. Default to `person'"
(defun eudc-ldap-format-query-as-rfc1558 (query)
"Format the EUDC QUERY list as a RFC1558 LDAP search filter."
- (format "(&%s)"
- (apply 'concat
- (mapcar (lambda (item)
- (format "(%s=%s)"
- (car item)
- (eudc-ldap-escape-query-special-chars (cdr item))))
- query))))
-
+ (let ((formatter (lambda (item &optional wildcard)
+ (format "(%s=%s)"
+ (car item)
+ (concat
+ (eudc-ldap-escape-query-special-chars
+ (cdr item)) (if wildcard "*" ""))))))
+ (format "(&%s)"
+ (concat
+ (mapconcat formatter (butlast query) "")
+ (funcall formatter (car (last query)) t)))))
;;}}}
diff --git a/lisp/net/eudcb-mab.el b/lisp/net/eudcb-mab.el
index 81d8f24ecb2..a11cd95b05d 100644
--- a/lisp/net/eudcb-mab.el
+++ b/lisp/net/eudcb-mab.el
@@ -3,7 +3,7 @@
;; Copyright (C) 2003-2015 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw@newartisans.com>
-;; Maintainer: emacs-devel@gnu.org
+;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org>
;; Keywords: comm
;; Package: eudc
diff --git a/lisp/net/eudcb-ph.el b/lisp/net/eudcb-ph.el
index fc6aad671c0..1897e0b08bc 100644
--- a/lisp/net/eudcb-ph.el
+++ b/lisp/net/eudcb-ph.el
@@ -3,7 +3,8 @@
;; Copyright (C) 1998-2015 Free Software Foundation, Inc.
;; Author: Oscar Figueiredo <oscar@cpe.fr>
-;; Maintainer: Pavel Janík <Pavel@Janik.cz>
+;; Pavel Janík <Pavel@Janik.cz>
+;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org>
;; Keywords: comm
;; Package: eudc
diff --git a/lisp/net/eww.el b/lisp/net/eww.el
index 913f0c501ae..ec7a0baacf6 100644
--- a/lisp/net/eww.el
+++ b/lisp/net/eww.el
@@ -1,4 +1,4 @@
-;;; eww.el --- Emacs Web Wowser
+;;; eww.el --- Emacs Web Wowser -*- lexical-binding:t -*-
;; Copyright (C) 2013-2015 Free Software Foundation, Inc.
@@ -28,13 +28,16 @@
(require 'format-spec)
(require 'shr)
(require 'url)
+(require 'url-queue)
+(require 'url-util) ; for url-get-url-at-point
(require 'mm-url)
+(eval-when-compile (require 'subr-x)) ;; for string-trim
(defgroup eww nil
"Emacs Web Wowser"
- :version "24.4"
+ :version "25.1"
:link '(custom-manual "(eww) Top")
- :group 'hypermedia
+ :group 'web
:prefix "eww-")
(defcustom eww-header-line-format "%t: %u"
@@ -57,6 +60,64 @@
:group 'eww
:type 'string)
+(defcustom eww-suggest-uris
+ '(eww-links-at-point
+ url-get-url-at-point
+ eww-current-url)
+ "List of functions called to form the list of default URIs for `eww'.
+Each of the elements is a function returning either a string or a list
+of strings. The results will be joined into a single list with
+duplicate entries (if any) removed."
+ :version "25.1"
+ :group 'eww
+ :type 'hook
+ :options '(eww-links-at-point
+ url-get-url-at-point
+ eww-current-url))
+
+(defcustom eww-bookmarks-directory user-emacs-directory
+ "Directory where bookmark files will be stored."
+ :version "25.1"
+ :group 'eww
+ :type 'string)
+
+(defcustom eww-desktop-remove-duplicates t
+ "Whether to remove duplicates from the history when saving desktop data.
+If non-nil, repetitive EWW history entries (comprising of the URI, the
+title, and the point position) will not be saved as part of the Emacs
+desktop. Otherwise, such entries will be retained."
+ :version "25.1"
+ :group 'eww
+ :type 'boolean)
+
+(defcustom eww-restore-desktop nil
+ "How to restore EWW buffers on `desktop-restore'.
+If t or 'auto, the buffers will be reloaded automatically.
+If nil, buffers will require manual reload, and will contain the text
+specified in `eww-restore-reload-prompt' instead of the actual Web
+page contents."
+ :version "25.1"
+ :group 'eww
+ :type '(choice (const :tag "Restore all automatically" t)
+ (const :tag "Require manual reload" nil)))
+
+(defcustom eww-restore-reload-prompt
+ "\n\n *** Use \\[eww-reload] to reload this buffer. ***\n"
+ "The string to put in the buffers not reloaded on `desktop-restore'.
+This prompt will be used if `eww-restore-desktop' is nil.
+
+The string will be passed through `substitute-command-keys'."
+ :version "25.1"
+ :group 'eww
+ :type 'string)
+
+(defcustom eww-history-limit 50
+ "Maximum number of entries to retain in the history."
+ :version "25.1"
+ :group 'eww
+ :type '(choice (const :tag "Unlimited" nil)
+ integer))
+
(defcustom eww-use-external-browser-for-content-type
"\\`\\(video/\\|audio/\\|application/ogg\\)"
"Always use external browser for specified content-type."
@@ -65,6 +126,12 @@
:type '(choice (const :tag "Never" nil)
regexp))
+(defcustom eww-after-render-hook nil
+ "A hook called after eww has finished rendering the buffer."
+ :version "25.1"
+ :group 'eww
+ :type 'hook)
+
(defcustom eww-form-checkbox-selected-symbol "[X]"
"Symbol used to represent a selected checkbox.
See also `eww-form-checkbox-symbol'."
@@ -92,6 +159,14 @@ See also `eww-form-checkbox-selected-symbol'."
:version "24.4"
:group 'eww)
+(defface eww-form-file
+ '((((type x w32 ns) (class color)) ; Like default mode line
+ :box (:line-width 2 :style released-button)
+ :background "#808080" :foreground "black"))
+ "Face for eww buffer buttons."
+ :version "25.1"
+ :group 'eww)
+
(defface eww-form-checkbox
'((((type x w32 ns) (class color)) ; Like default mode line
:box (:line-width 2 :style released-button)
@@ -124,21 +199,24 @@ See also `eww-form-checkbox-selected-symbol'."
:version "24.4"
:group 'eww)
-(defvar eww-current-url nil)
-(defvar eww-current-dom nil)
-(defvar eww-current-source nil)
-(defvar eww-current-title ""
- "Title of current page.")
+(defface eww-invalid-certificate
+ '((default :weight bold)
+ (((class color)) :foreground "red"))
+ "Face for web pages with invalid certificates."
+ :version "25.1"
+ :group 'eww)
+
+(defface eww-valid-certificate
+ '((default :weight bold)
+ (((class color)) :foreground "ForestGreen"))
+ "Face for web pages with valid certificates."
+ :version "25.1"
+ :group 'eww)
+
+(defvar eww-data nil)
(defvar eww-history nil)
(defvar eww-history-position 0)
-(defvar eww-next-url nil)
-(defvar eww-previous-url nil)
-(defvar eww-up-url nil)
-(defvar eww-home-url nil)
-(defvar eww-start-url nil)
-(defvar eww-contents-url nil)
-
(defvar eww-local-regex "localhost"
"When this regex is found in the URL, it's not a keyword but an address.")
@@ -147,29 +225,67 @@ See also `eww-form-checkbox-selected-symbol'."
(define-key map "\r" 'eww-follow-link)
map))
+(defun eww-suggested-uris nil
+ "Return the list of URIs to suggest at the `eww' prompt.
+This list can be customized via `eww-suggest-uris'."
+ (let ((obseen (make-vector 42 0))
+ (uris nil))
+ (dolist (fun eww-suggest-uris)
+ (let ((ret (funcall fun)))
+ (dolist (uri (if (stringp ret) (list ret) ret))
+ (when (and uri (not (intern-soft uri obseen)))
+ (intern uri obseen)
+ (push uri uris)))))
+ (nreverse uris)))
+
;;;###autoload
(defun eww (url)
"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'."
- (interactive "sEnter URL or keywords: ")
- (cond ((string-match-p "\\`file://" url))
+ (interactive
+ (let* ((uris (eww-suggested-uris))
+ (prompt (concat "Enter URL or keywords"
+ (if uris (format " (default %s)" (car uris)) "")
+ ": ")))
+ (list (read-string prompt nil nil uris))))
+ (setq url (string-trim url))
+ (cond ((string-match-p "\\`file:/" url))
+ ;; Don't mangle file: URLs at all.
((string-match-p "\\`ftp://" url)
(user-error "FTP is not supported."))
(t
- (if (and (= (length (split-string url)) 1)
- (or (and (not (string-match-p "\\`[\"\'].*[\"\']\\'" url))
- (> (length (split-string url "\\.")) 1))
- (string-match eww-local-regex url)))
+ ;; Anything that starts with something that vaguely looks
+ ;; like a protocol designator is interpreted as a full URL.
+ (if (or (string-match "\\`[A-Za-z]+:" url)
+ ;; Also try to match "naked" URLs like
+ ;; en.wikipedia.org/wiki/Free software
+ (string-match "\\`[A-Za-z_]+\\.[A-Za-z._]+/" url)
+ (and (= (length (split-string url)) 1)
+ (or (and (not (string-match-p "\\`[\"\'].*[\"\']\\'" url))
+ (> (length (split-string url "[.:]")) 1))
+ (string-match eww-local-regex url))))
(progn
(unless (string-match-p "\\`[a-zA-Z][-a-zA-Z0-9+.]*://" url)
(setq url (concat "http://" url)))
- ;; some site don't redirect final /
+ ;; Some sites do not redirect final /
(when (string= (url-filename (url-generic-parse-url url)) "")
(setq url (concat url "/"))))
(setq url (concat eww-search-prefix
(replace-regexp-in-string " " "+" url))))))
- (url-retrieve url 'eww-render (list url)))
+ (if (eq major-mode 'eww-mode)
+ (when (or (plist-get eww-data :url)
+ (plist-get eww-data :dom))
+ (eww-save-history))
+ (eww-setup-buffer)
+ (plist-put eww-data :url url)
+ (plist-put eww-data :title "")
+ (eww-update-header-line-format)
+ (let ((inhibit-read-only t))
+ (insert (format "Loading %s..." url))
+ (goto-char (point-min))))
+ (url-retrieve url 'eww-render
+ (list url nil (current-buffer))))
;;;###autoload (defalias 'browse-web 'eww)
@@ -182,7 +298,14 @@ word(s) will be searched for via `eww-search-prefix'."
"/")
(expand-file-name file))))
-(defun eww-render (status url &optional point)
+;;;###autoload
+(defun eww-search-words (&optional beg end)
+ "Search the web for the text between the point and marker.
+See the `eww-search-prefix' variable for the search engine used."
+ (interactive "r")
+ (eww (buffer-substring beg end)))
+
+(defun eww-render (status url &optional point buffer encode)
(let ((redirect (plist-get status :redirect)))
(when redirect
(setq url redirect)))
@@ -196,26 +319,31 @@ word(s) will be searched for via `eww-search-prefix'."
(or (cdr (assq 'charset (cdr content-type)))
(eww-detect-charset (equal (car content-type)
"text/html"))
- "utf8"))))
+ "utf-8"))))
(data-buffer (current-buffer)))
+ ;; Save the https peer status.
+ (with-current-buffer buffer
+ (plist-put eww-data :peer (plist-get status :peer)))
(unwind-protect
(progn
- (setq eww-current-title "")
(cond
((and eww-use-external-browser-for-content-type
(string-match-p eww-use-external-browser-for-content-type
(car content-type)))
(eww-browse-with-external-browser url))
((equal (car content-type) "text/html")
- (eww-display-html charset url nil point))
+ (eww-display-html charset url nil point buffer encode))
+ ((equal (car content-type) "application/pdf")
+ (eww-display-pdf))
((string-match-p "\\`image/" (car content-type))
- (eww-display-image)
- (eww-update-header-line-format))
+ (eww-display-image buffer))
(t
- (eww-display-raw)
- (eww-update-header-line-format)))
- (setq eww-current-url url
- eww-history-position 0))
+ (eww-display-raw buffer encode)))
+ (with-current-buffer buffer
+ (plist-put eww-data :url url)
+ (eww-update-header-line-format)
+ (setq eww-history-position 0)
+ (run-hooks 'eww-after-render-hook)))
(kill-buffer data-buffer))))
(defun eww-parse-headers ()
@@ -247,139 +375,170 @@ word(s) will be searched for via `eww-search-prefix'."
(declare-function libxml-parse-html-region "xml.c"
(start end &optional base-url))
-(defun eww-display-html (charset url &optional document point)
- (or (fboundp 'libxml-parse-html-region)
- (error "This function requires Emacs to be compiled with libxml2"))
- (unless (eq charset 'utf8)
- (condition-case nil
- (decode-coding-region (point) (point-max) charset)
- (coding-system-error nil)))
+(defun eww-display-html (charset url &optional document point buffer encode)
+ (unless (fboundp 'libxml-parse-html-region)
+ (error "This function requires Emacs to be compiled with libxml2"))
+ (unless (buffer-live-p buffer)
+ (error "Buffer %s doesn't exist" buffer))
+ ;; There should be a better way to abort loading images
+ ;; asynchronously.
+ (setq url-queue nil)
(let ((document
(or document
(list
'base (list (cons 'href url))
- (libxml-parse-html-region (point) (point-max))))))
- (setq eww-current-source (buffer-substring (point) (point-max)))
- (eww-setup-buffer)
- (setq eww-current-dom document)
- (let ((inhibit-read-only t)
- (after-change-functions nil)
- (shr-width nil)
- (shr-target-id (url-target (url-generic-parse-url url)))
- (shr-external-rendering-functions
- '((title . eww-tag-title)
- (form . eww-tag-form)
- (input . eww-tag-input)
- (textarea . eww-tag-textarea)
- (body . eww-tag-body)
- (select . eww-tag-select)
- (link . eww-tag-link)
- (a . eww-tag-a))))
- (shr-insert-document document)
- (cond
- (point
- (goto-char point))
- (shr-target-id
- (goto-char (point-min))
- (let ((point (next-single-property-change
- (point-min) 'shr-target-id)))
- (when point
- (goto-char point))))
- (t
- (goto-char (point-min)))))
- (setq eww-current-url url
- eww-history-position 0)
- (eww-update-header-line-format)))
-
-(defun eww-handle-link (cont)
- (let* ((rel (assq :rel cont))
- (href (assq :href cont))
- (where (assoc
- ;; The text associated with :rel is case-insensitive.
- (if rel (downcase (cdr rel)))
- '(("next" . eww-next-url)
- ;; Texinfo uses "previous", but HTML specifies
- ;; "prev", so recognize both.
- ("previous" . eww-previous-url)
- ("prev" . eww-previous-url)
- ;; HTML specifies "start" but also "contents",
- ;; and Gtk seems to use "home". Recognize
- ;; them all; but store them in different
- ;; variables so that we can readily choose the
- ;; "best" one.
- ("start" . eww-start-url)
- ("home" . eww-home-url)
- ("contents" . eww-contents-url)
- ("up" . eww-up-url)))))
+ (progn
+ (when (or (and encode
+ (not (eq charset encode)))
+ (not (eq charset 'utf-8)))
+ (condition-case nil
+ (decode-coding-region (point) (point-max)
+ (or encode charset))
+ (coding-system-error nil)))
+ (libxml-parse-html-region (point) (point-max))))))
+ (source (and (null document)
+ (buffer-substring (point) (point-max)))))
+ (with-current-buffer buffer
+ (plist-put eww-data :source source)
+ (plist-put eww-data :dom document)
+ (let ((inhibit-read-only t)
+ (inhibit-modification-hooks t)
+ (shr-target-id (url-target (url-generic-parse-url url)))
+ (shr-external-rendering-functions
+ '((title . eww-tag-title)
+ (form . eww-tag-form)
+ (input . eww-tag-input)
+ (textarea . eww-tag-textarea)
+ (body . eww-tag-body)
+ (select . eww-tag-select)
+ (link . eww-tag-link)
+ (a . eww-tag-a))))
+ (erase-buffer)
+ (shr-insert-document document)
+ (cond
+ (point
+ (goto-char point))
+ (shr-target-id
+ (goto-char (point-min))
+ (let ((point (next-single-property-change
+ (point-min) 'shr-target-id)))
+ (when point
+ (goto-char point))))
+ (t
+ (goto-char (point-min))
+ ;; Don't leave point inside forms, because the normal eww
+ ;; commands aren't available there.
+ (while (and (not (eobp))
+ (get-text-property (point) 'eww-form))
+ (forward-line 1)))))
+ (eww-size-text-inputs))))
+
+(defun eww-handle-link (dom)
+ (let* ((rel (dom-attr dom 'rel))
+ (href (dom-attr dom 'href))
+ (where (assoc
+ ;; The text associated with :rel is case-insensitive.
+ (if rel (downcase rel))
+ '(("next" . :next)
+ ;; Texinfo uses "previous", but HTML specifies
+ ;; "prev", so recognize both.
+ ("previous" . :previous)
+ ("prev" . :previous)
+ ;; HTML specifies "start" but also "contents",
+ ;; and Gtk seems to use "home". Recognize
+ ;; them all; but store them in different
+ ;; variables so that we can readily choose the
+ ;; "best" one.
+ ("start" . :start)
+ ("home" . :home)
+ ("contents" . :contents)
+ ("up" . :up)))))
(and href
where
- (set (cdr where) (cdr href)))))
+ (plist-put eww-data (cdr where) href))))
-(defun eww-tag-link (cont)
- (eww-handle-link cont)
- (shr-generic cont))
+(defun eww-tag-link (dom)
+ (eww-handle-link dom)
+ (shr-generic dom))
-(defun eww-tag-a (cont)
- (eww-handle-link cont)
+(defun eww-tag-a (dom)
+ (eww-handle-link dom)
(let ((start (point)))
- (shr-tag-a cont)
+ (shr-tag-a dom)
(put-text-property start (point) 'keymap eww-link-keymap)))
(defun eww-update-header-line-format ()
- (if eww-header-line-format
- (setq header-line-format
- (replace-regexp-in-string
- "%" "%%"
- ;; FIXME? Title can be blank. Default to, eg, last component
- ;; of url?
- (format-spec eww-header-line-format
- `((?u . ,eww-current-url)
- (?t . ,eww-current-title)))))
- (setq header-line-format nil)))
-
-(defun eww-tag-title (cont)
- (setq eww-current-title "")
- (dolist (sub cont)
- (when (eq (car sub) 'text)
- (setq eww-current-title (concat eww-current-title (cdr sub)))))
+ (setq header-line-format
+ (and eww-header-line-format
+ (let ((title (plist-get eww-data :title))
+ (peer (plist-get eww-data :peer)))
+ (when (zerop (length title))
+ (setq title "[untitled]"))
+ ;; This connection has is https.
+ (when peer
+ (setq title
+ (propertize title 'face
+ (if (plist-get peer :warnings)
+ 'eww-invalid-certificate
+ 'eww-valid-certificate))))
+ (replace-regexp-in-string
+ "%" "%%"
+ (format-spec
+ eww-header-line-format
+ `((?u . ,(or (plist-get eww-data :url) ""))
+ (?t . ,title))))))))
+
+(defun eww-tag-title (dom)
+ (plist-put eww-data :title
+ (replace-regexp-in-string
+ "^ \\| $" ""
+ (replace-regexp-in-string "[ \t\r\n]+" " " (dom-text dom))))
(eww-update-header-line-format))
-(defun eww-tag-body (cont)
+(defun eww-tag-body (dom)
(let* ((start (point))
- (fgcolor (cdr (or (assq :fgcolor cont)
- (assq :text cont))))
- (bgcolor (cdr (assq :bgcolor cont)))
+ (fgcolor (or (dom-attr dom 'fgcolor) (dom-attr dom 'text)))
+ (bgcolor (dom-attr dom 'bgcolor))
(shr-stylesheet (list (cons 'color fgcolor)
(cons 'background-color bgcolor))))
- (shr-generic cont)
- (eww-colorize-region start (point) fgcolor bgcolor)))
-
-(defun eww-colorize-region (start end fg &optional bg)
- (when (or fg bg)
- (let ((new-colors (shr-color-check fg bg)))
- (when new-colors
- (when fg
- (add-face-text-property start end
- (list :foreground (cadr new-colors))
- t))
- (when bg
- (add-face-text-property start end
- (list :background (car new-colors))
- t))))))
-
-(defun eww-display-raw ()
- (let ((data (buffer-substring (point) (point-max))))
- (eww-setup-buffer)
- (let ((inhibit-read-only t))
- (insert data))
- (goto-char (point-min))))
+ (shr-generic dom)
+ (shr-colorize-region start (point) fgcolor bgcolor)))
-(defun eww-display-image ()
+(defun eww-display-raw (buffer &optional encode)
+ (let ((data (buffer-substring (point) (point-max))))
+ (unless (buffer-live-p buffer)
+ (error "Buffer %s doesn't exist" buffer))
+ (with-current-buffer buffer
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (insert data)
+ (unless (eq encode 'utf-8)
+ (encode-coding-region (point-min) (1+ (length data)) 'utf-8)
+ (condition-case nil
+ (decode-coding-region (point-min) (1+ (length data)) encode)
+ (coding-system-error nil))))
+ (goto-char (point-min)))))
+
+(defun eww-display-image (buffer)
(let ((data (shr-parse-image-data)))
- (eww-setup-buffer)
- (let ((inhibit-read-only t))
- (shr-put-image data nil))
- (goto-char (point-min))))
+ (unless (buffer-live-p buffer)
+ (error "Buffer %s doesn't exist" buffer))
+ (with-current-buffer buffer
+ (let ((inhibit-read-only t))
+ (erase-buffer)
+ (shr-put-image data nil))
+ (goto-char (point-min)))))
+
+(declare-function mailcap-view-mime "mailcap" (type))
+(defun eww-display-pdf ()
+ (let ((data (buffer-substring (point) (point-max))))
+ (switch-to-buffer (get-buffer-create "*eww pdf*"))
+ (let ((coding-system-for-write 'raw-text)
+ (inhibit-read-only t))
+ (erase-buffer)
+ (insert data)
+ (mailcap-view-mime "application/pdf")))
+ (goto-char (point-min)))
(defun eww-setup-buffer ()
(switch-to-buffer (get-buffer-create "*eww*"))
@@ -387,37 +546,98 @@ word(s) will be searched for via `eww-search-prefix'."
(remove-overlays)
(erase-buffer))
(unless (eq major-mode 'eww-mode)
- (eww-mode))
- (setq-local eww-next-url nil)
- (setq-local eww-previous-url nil)
- (setq-local eww-up-url nil)
- (setq-local eww-home-url nil)
- (setq-local eww-start-url nil)
- (setq-local eww-contents-url nil))
+ (eww-mode)))
+
+(defun eww-current-url nil
+ "Return URI of the Web page the current EWW buffer is visiting."
+ (plist-get eww-data :url))
+
+(defun eww-links-at-point ()
+ "Return list of URIs, if any, linked at point."
+ (remq nil
+ (list (get-text-property (point) 'shr-url)
+ (get-text-property (point) 'image-url))))
(defun eww-view-source ()
+ "View the HTML source code of the current page."
(interactive)
(let ((buf (get-buffer-create "*eww-source*"))
- (source eww-current-source))
+ (source (plist-get eww-data :source)))
(with-current-buffer buf
- (delete-region (point-min) (point-max))
- (insert (or eww-current-source "no source"))
- (goto-char (point-min))
- (when (fboundp 'html-mode)
- (html-mode)))
+ (let ((inhibit-read-only t))
+ (delete-region (point-min) (point-max))
+ (insert (or source "no source"))
+ (goto-char (point-min))
+ (when (fboundp 'html-mode)
+ (html-mode))))
(view-buffer buf)))
+(defun eww-readable ()
+ "View the main \"readable\" parts of the current web page.
+This command uses heuristics to find the parts of the web page that
+contains the main textual portion, leaving out navigation menus and
+the like."
+ (interactive)
+ (let* ((old-data eww-data)
+ (dom (with-temp-buffer
+ (insert (plist-get old-data :source))
+ (condition-case nil
+ (decode-coding-region (point-min) (point-max) 'utf-8)
+ (coding-system-error nil))
+ (libxml-parse-html-region (point-min) (point-max)))))
+ (eww-score-readability dom)
+ (eww-save-history)
+ (eww-display-html nil nil
+ (eww-highest-readability dom)
+ nil (current-buffer))
+ (dolist (elem '(:source :url :title :next :previous :up))
+ (plist-put eww-data elem (plist-get old-data elem)))
+ (eww-update-header-line-format)))
+
+(defun eww-score-readability (node)
+ (let ((score -1))
+ (cond
+ ((memq (dom-tag node) '(script head comment))
+ (setq score -2))
+ ((eq (dom-tag node) 'meta)
+ (setq score -1))
+ ((eq (dom-tag node) 'img)
+ (setq score 2))
+ ((eq (dom-tag node) 'a)
+ (setq score (- (length (split-string (dom-text node))))))
+ (t
+ (dolist (elem (dom-children node))
+ (if (stringp elem)
+ (setq score (+ score (length (split-string elem))))
+ (setq score (+ score
+ (or (cdr (assoc :eww-readability-score (cdr elem)))
+ (eww-score-readability elem))))))))
+ ;; Cache the score of the node to avoid recomputing all the time.
+ (dom-set-attribute node :eww-readability-score score)
+ score))
+
+(defun eww-highest-readability (node)
+ (let ((result node)
+ highest)
+ (dolist (elem (dom-non-text-children node))
+ (when (> (or (dom-attr
+ (setq highest (eww-highest-readability elem))
+ :eww-readability-score)
+ most-negative-fixnum)
+ (or (dom-attr result :eww-readability-score)
+ most-negative-fixnum))
+ (setq result highest)))
+ result))
+
(defvar eww-mode-map
(let ((map (make-sparse-keymap)))
- (suppress-keymap map)
- (define-key map "q" 'quit-window)
- (define-key map "g" 'eww-reload)
+ (set-keymap-parent map special-mode-map)
+ (define-key map "g" 'eww-reload) ;FIXME: revert-buffer-function instead!
+ (define-key map "G" 'eww)
(define-key map [?\t] 'shr-next-link)
(define-key map [?\M-\t] 'shr-previous-link)
+ (define-key map [backtab] 'shr-previous-link)
(define-key map [delete] 'scroll-down-command)
- (define-key map [?\S-\ ] 'scroll-down-command)
- (define-key map "\177" 'scroll-down-command)
- (define-key map " " 'scroll-up-command)
(define-key map "l" 'eww-back-url)
(define-key map "r" 'eww-forward-url)
(define-key map "n" 'eww-next-url)
@@ -429,7 +649,10 @@ word(s) will be searched for via `eww-search-prefix'."
(define-key map "w" 'eww-copy-page-url)
(define-key map "C" 'url-cookie-list)
(define-key map "v" 'eww-view-source)
+ (define-key map "R" 'eww-readable)
(define-key map "H" 'eww-list-histories)
+ (define-key map "E" 'eww-set-character-encoding)
+ (define-key map "S" 'eww-list-buffers)
(define-key map "b" 'eww-add-bookmark)
(define-key map "B" 'eww-list-bookmarks)
@@ -438,7 +661,7 @@ word(s) will be searched for via `eww-search-prefix'."
(easy-menu-define nil map ""
'("Eww"
- ["Exit" eww-quit t]
+ ["Exit" quit-window t]
["Close browser" quit-window t]
["Reload" eww-reload t]
["Back to previous page" eww-back-url
@@ -450,15 +673,17 @@ word(s) will be searched for via `eww-search-prefix'."
["View page source" eww-view-source]
["Copy page URL" eww-copy-page-url t]
["List histories" eww-list-histories t]
+ ["List buffers" eww-list-buffers t]
["Add bookmark" eww-add-bookmark t]
["List bookmarks" eww-list-bookmarks t]
- ["List cookies" url-cookie-list t]))
+ ["List cookies" url-cookie-list t]
+ ["Character Encoding" eww-set-character-encoding]))
map))
(defvar eww-tool-bar-map
(let ((map (make-sparse-keymap)))
(dolist (tool-bar-item
- '((eww-quit . "close")
+ '((quit-window . "close")
(eww-reload . "refresh")
(eww-back-url . "left-arrow")
(eww-forward-url . "right-arrow")
@@ -470,30 +695,28 @@ word(s) will be searched for via `eww-search-prefix'."
map)
"Tool bar for `eww-mode'.")
-(define-derived-mode eww-mode nil "eww"
- "Mode for browsing the web.
-
-\\{eww-mode-map}"
- ;; FIXME? This seems a strange default.
- (setq-local eww-current-url 'author)
- (setq-local eww-current-dom nil)
- (setq-local eww-current-source nil)
- (setq-local eww-current-title "")
- (setq-local browse-url-browser-function 'eww-browse-url)
- (setq-local after-change-functions 'eww-process-text-input)
+(define-derived-mode eww-mode special-mode "eww"
+ "Mode for browsing the web."
+ (setq-local eww-data (list :title ""))
+ (setq-local browse-url-browser-function #'eww-browse-url)
+ (add-hook 'after-change-functions #'eww-process-text-input nil t)
(setq-local eww-history nil)
(setq-local eww-history-position 0)
(when (boundp 'tool-bar-map)
- (setq-local tool-bar-map eww-tool-bar-map))
+ (setq-local tool-bar-map eww-tool-bar-map))
+ ;; desktop support
+ (setq-local desktop-save-buffer #'eww-desktop-misc-data)
+ ;; multi-page isearch support
+ (setq-local multi-isearch-next-buffer-function #'eww-isearch-next-buffer)
+ (setq truncate-lines t)
(buffer-disable-undo)
- ;;(setq buffer-read-only t)
- )
+ (setq buffer-read-only t))
;;;###autoload
-(defun eww-browse-url (url &optional _new-window)
- (when (and (equal major-mode 'eww-mode)
- eww-current-url)
- (eww-save-history))
+(defun eww-browse-url (url &optional new-window)
+ (cond (new-window
+ (switch-to-buffer (generate-new-buffer "*eww*"))
+ (eww-mode)))
(eww url))
(defun eww-back-url ()
@@ -514,23 +737,25 @@ word(s) will be searched for via `eww-search-prefix'."
(eww-restore-history (elt eww-history (1- eww-history-position))))
(defun eww-restore-history (elem)
- (let ((inhibit-read-only t))
- (erase-buffer)
- (insert (plist-get elem :text))
- (setq eww-current-source (plist-get elem :source))
- (setq eww-current-dom (plist-get elem :dom))
- (goto-char (plist-get elem :point))
- (setq eww-current-url (plist-get elem :url)
- eww-current-title (plist-get elem :title))
- (eww-update-header-line-format)))
+ (let ((inhibit-read-only t)
+ (inhibit-modification-hooks t)
+ (text (plist-get elem :text)))
+ (setq eww-data elem)
+ (if (null text)
+ (eww-reload) ; FIXME: restore :point?
+ (erase-buffer)
+ (insert text)
+ (goto-char (plist-get elem :point))
+ (eww-update-header-line-format))))
(defun eww-next-url ()
"Go to the page marked `next'.
A page is marked `next' if rel=\"next\" appears in a <link>
or <a> tag."
(interactive)
- (if eww-next-url
- (eww-browse-url (shr-expand-url eww-next-url eww-current-url))
+ (if (plist-get eww-data :next)
+ (eww-browse-url (shr-expand-url (plist-get eww-data :next)
+ (plist-get eww-data :url)))
(user-error "No `next' on this page")))
(defun eww-previous-url ()
@@ -538,8 +763,9 @@ or <a> tag."
A page is marked `previous' if rel=\"previous\" appears in a <link>
or <a> tag."
(interactive)
- (if eww-previous-url
- (eww-browse-url (shr-expand-url eww-previous-url eww-current-url))
+ (if (plist-get eww-data :previous)
+ (eww-browse-url (shr-expand-url (plist-get eww-data :previous)
+ (plist-get eww-data :url)))
(user-error "No `previous' on this page")))
(defun eww-up-url ()
@@ -547,8 +773,9 @@ or <a> tag."
A page is marked `up' if rel=\"up\" appears in a <link>
or <a> tag."
(interactive)
- (if eww-up-url
- (eww-browse-url (shr-expand-url eww-up-url eww-current-url))
+ (if (plist-get eww-data :up)
+ (eww-browse-url (shr-expand-url (plist-get eww-data :up)
+ (plist-get eww-data :url)))
(user-error "No `up' on this page")))
(defun eww-top-url ()
@@ -556,18 +783,26 @@ or <a> tag."
A page is marked `top' if rel=\"start\", rel=\"home\", or rel=\"contents\"
appears in a <link> or <a> tag."
(interactive)
- (let ((best-url (or eww-start-url
- eww-contents-url
- eww-home-url)))
+ (let ((best-url (or (plist-get eww-data :start)
+ (plist-get eww-data :contents)
+ (plist-get eww-data :home))))
(if best-url
- (eww-browse-url (shr-expand-url best-url eww-current-url))
+ (eww-browse-url (shr-expand-url best-url (plist-get eww-data :url)))
(user-error "No `top' for this page"))))
-(defun eww-reload ()
- "Reload the current page."
- (interactive)
- (url-retrieve eww-current-url 'eww-render
- (list eww-current-url (point))))
+(defun eww-reload (&optional local encode)
+ "Reload the current page.
+If LOCAL (the command prefix), don't reload the page from the
+network, but just re-display the HTML already fetched."
+ (interactive "P")
+ (let ((url (plist-get eww-data :url)))
+ (if local
+ (if (null (plist-get eww-data :dom))
+ (error "No current HTML data")
+ (eww-display-html 'utf-8 url (plist-get eww-data :dom)
+ (point) (current-buffer)))
+ (url-retrieve url 'eww-render
+ (list url (point) (current-buffer) encode)))))
;; Form support.
@@ -579,6 +814,12 @@ appears in a <link> or <a> tag."
(define-key map [(control c) (control c)] 'eww-submit)
map))
+(defvar eww-submit-file
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\r" 'eww-select-file)
+ (define-key map [(control c) (control c)] 'eww-submit)
+ map))
+
(defvar eww-checkbox-map
(let ((map (make-sparse-keymap)))
(define-key map " " 'eww-toggle-checkbox)
@@ -643,13 +884,12 @@ appears in a <link> or <a> tag."
(1- (next-single-property-change
(point) 'eww-form nil (point-max))))
-(defun eww-tag-form (cont)
- (let ((eww-form
- (list (assq :method cont)
- (assq :action cont)))
+(defun eww-tag-form (dom)
+ (let ((eww-form (list (cons :method (dom-attr dom 'method))
+ (cons :action (dom-attr dom 'action))))
(start (point)))
(shr-ensure-paragraph)
- (shr-generic cont)
+ (shr-generic dom)
(unless (bolp)
(insert "\n"))
(insert "\n")
@@ -657,9 +897,9 @@ appears in a <link> or <a> tag."
(put-text-property start (1+ start)
'eww-form eww-form))))
-(defun eww-form-submit (cont)
+(defun eww-form-submit (dom)
(let ((start (point))
- (value (cdr (assq :value cont))))
+ (value (dom-attr dom 'value)))
(setq value
(if (zerop (length value))
"Submit"
@@ -670,48 +910,74 @@ appears in a <link> or <a> tag."
(list :eww-form eww-form
:value value
:type "submit"
- :name (cdr (assq :name cont))))
+ :name (dom-attr dom 'name)))
(put-text-property start (point) 'keymap eww-submit-map)
(insert " ")))
-(defun eww-form-checkbox (cont)
+(defun eww-form-checkbox (dom)
(let ((start (point)))
- (if (cdr (assq :checked cont))
+ (if (dom-attr dom 'checked)
(insert eww-form-checkbox-selected-symbol)
(insert eww-form-checkbox-symbol))
(add-face-text-property start (point) 'eww-form-checkbox)
(put-text-property start (point) 'eww-form
(list :eww-form eww-form
- :value (cdr (assq :value cont))
- :type (downcase (cdr (assq :type cont)))
- :checked (cdr (assq :checked cont))
- :name (cdr (assq :name cont))))
+ :value (dom-attr dom 'value)
+ :type (downcase (dom-attr dom 'type))
+ :checked (dom-attr dom 'checked)
+ :name (dom-attr dom 'name)))
(put-text-property start (point) 'keymap eww-checkbox-map)
(insert " ")))
-(defun eww-form-text (cont)
+(defun eww-form-file (dom)
(let ((start (point))
- (type (downcase (or (cdr (assq :type cont))
- "text")))
- (value (or (cdr (assq :value cont)) ""))
- (width (string-to-number
- (or (cdr (assq :size cont))
- "40")))
- (readonly-property (if (or (cdr (assq :disabled cont))
- (cdr (assq :readonly cont)))
+ (value (dom-attr dom 'value)))
+ (setq value
+ (if (zerop (length value))
+ " No file selected"
+ value))
+ (insert "Browse")
+ (add-face-text-property start (point) 'eww-form-file)
+ (insert value)
+ (put-text-property start (point) 'eww-form
+ (list :eww-form eww-form
+ :value (dom-attr dom 'value)
+ :type (downcase (dom-attr dom 'type))
+ :name (dom-attr dom 'name)))
+ (put-text-property start (point) 'keymap eww-submit-file)
+ (insert " ")))
+
+(defun eww-select-file ()
+ "Change the value of the upload file menu under point."
+ (interactive)
+ (let* ((input (get-text-property (point) 'eww-form)))
+ (let ((filename
+ (let ((insert-default-directory t))
+ (read-file-name "filename: "))))
+ (eww-update-field filename (length "Browse"))
+ (plist-put input :filename filename))))
+
+(defun eww-form-text (dom)
+ (let ((start (point))
+ (type (downcase (or (dom-attr dom 'type) "text")))
+ (value (or (dom-attr dom 'value) ""))
+ (width (string-to-number (or (dom-attr dom 'size) "40")))
+ (readonly-property (if (or (dom-attr dom 'disabled)
+ (dom-attr dom 'readonly))
'read-only
'inhibit-read-only)))
(insert value)
(when (< (length value) width)
(insert (make-string (- width (length value)) ? )))
(put-text-property start (point) 'face 'eww-form-text)
+ (put-text-property start (point) 'inhibit-read-only t)
(put-text-property start (point) 'local-map eww-text-map)
(put-text-property start (point) readonly-property t)
(put-text-property start (point) 'eww-form
(list :eww-form eww-form
:value value
:type type
- :name (cdr (assq :name cont))))
+ :name (dom-attr dom 'name)))
(insert " ")))
(defconst eww-text-input-types '("text" "password" "textarea"
@@ -721,63 +987,70 @@ appears in a <link> or <a> tag."
"List of input types which represent a text input.
See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
-(defun eww-process-text-input (beg end length)
- (let* ((form (get-text-property (min (1+ end) (point-max)) 'eww-form))
- (properties (text-properties-at end))
- (type (plist-get form :type)))
- (when (and form
- (member type eww-text-input-types))
- (cond
- ((zerop length)
- ;; Delete some space at the end.
- (save-excursion
- (goto-char
- (if (equal type "textarea")
- (1- (line-end-position))
- (eww-end-of-field)))
- (let ((new (- end beg)))
- (while (and (> new 0)
+(defun eww-process-text-input (beg end replace-length)
+ (when-let (pos (and (< (1+ end) (point-max))
+ (> (1- end) (point-min))
+ (cond
+ ((get-text-property (1+ end) 'eww-form)
+ (1+ end))
+ ((get-text-property (1- end) 'eww-form)
+ (1- end)))))
+ (let* ((form (get-text-property pos 'eww-form))
+ (properties (text-properties-at pos))
+ (inhibit-read-only t)
+ (length (- end beg replace-length))
+ (type (plist-get form :type)))
+ (when (and form
+ (member type eww-text-input-types))
+ (cond
+ ((> length 0)
+ ;; Delete some space at the end.
+ (save-excursion
+ (goto-char
+ (if (equal type "textarea")
+ (1- (line-end-position))
+ (eww-end-of-field)))
+ (while (and (> length 0)
(eql (following-char) ? ))
- (delete-region (point) (1+ (point)))
- (setq new (1- new))))
- (set-text-properties beg end properties)))
- ((> length 0)
- ;; Add padding.
- (save-excursion
- (goto-char
- (if (equal type "textarea")
- (1- (line-end-position))
- (eww-end-of-field)))
- (let ((start (point)))
- (insert (make-string length ? ))
- (set-text-properties start (point) properties)))))
- (let ((value (buffer-substring-no-properties
- (eww-beginning-of-field)
- (eww-end-of-field))))
- (when (string-match " +\\'" value)
- (setq value (substring value 0 (match-beginning 0))))
- (plist-put form :value value)
- (when (equal type "password")
- ;; Display passwords as asterisks.
- (let ((start (eww-beginning-of-field)))
- (put-text-property start (+ start (length value))
- 'display (make-string (length value) ?*))))))))
-
-(defun eww-tag-textarea (cont)
+ (delete-region (1- (point)) (point))
+ (cl-decf length))))
+ ((< length 0)
+ ;; Add padding.
+ (save-excursion
+ (goto-char (1- end))
+ (goto-char
+ (if (equal type "textarea")
+ (1- (line-end-position))
+ (1+ (eww-end-of-field))))
+ (let ((start (point)))
+ (insert (make-string (abs length) ? ))
+ (set-text-properties start (point) properties))
+ (goto-char (1- end)))))
+ (set-text-properties (plist-get form :start) (plist-get form :end)
+ properties)
+ (let ((value (buffer-substring-no-properties
+ (eww-beginning-of-field)
+ (eww-end-of-field))))
+ (when (string-match " +\\'" value)
+ (setq value (substring value 0 (match-beginning 0))))
+ (plist-put form :value value)
+ (when (equal type "password")
+ ;; Display passwords as asterisks.
+ (let ((start (eww-beginning-of-field)))
+ (put-text-property start (+ start (length value))
+ 'display (make-string (length value) ?*)))))))))
+
+(defun eww-tag-textarea (dom)
(let ((start (point))
- (value (or (cdr (assq :value cont)) ""))
- (lines (string-to-number
- (or (cdr (assq :rows cont))
- "10")))
- (width (string-to-number
- (or (cdr (assq :cols cont))
- "10")))
+ (value (or (dom-attr dom 'value) ""))
+ (lines (string-to-number (or (dom-attr dom 'rows) "10")))
+ (width (string-to-number (or (dom-attr dom 'cols) "10")))
end)
(shr-ensure-newline)
(insert value)
(shr-ensure-newline)
(when (< (count-lines start (point)) lines)
- (dotimes (i (- lines (count-lines start (point))))
+ (dotimes (_ (- lines (count-lines start (point))))
(insert "\n")))
(setq end (point-marker))
(goto-char start)
@@ -788,6 +1061,7 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
(insert (make-string pad ? ))))
(add-face-text-property (line-beginning-position)
(point) 'eww-form-textarea)
+ (put-text-property (line-beginning-position) (point) 'inhibit-read-only t)
(put-text-property (line-beginning-position) (point)
'local-map eww-textarea-map)
(forward-line 1))
@@ -795,21 +1069,22 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
(list :eww-form eww-form
:value value
:type "textarea"
- :name (cdr (assq :name cont))))))
+ :name (dom-attr dom 'name)))))
-(defun eww-tag-input (cont)
- (let ((type (downcase (or (cdr (assq :type cont))
- "text")))
+(defun eww-tag-input (dom)
+ (let ((type (downcase (or (dom-attr dom 'type) "text")))
(start (point)))
(cond
((or (equal type "checkbox")
(equal type "radio"))
- (eww-form-checkbox cont))
+ (eww-form-checkbox dom))
+ ((equal type "file")
+ (eww-form-file dom))
((equal type "submit")
- (eww-form-submit cont))
+ (eww-form-submit dom))
((equal type "hidden")
(let ((form eww-form)
- (name (cdr (assq :name cont))))
+ (name (dom-attr dom 'name)))
;; Don't add <input type=hidden> elements repeatedly.
(while (and form
(or (not (consp (car form)))
@@ -821,34 +1096,33 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
(nconc eww-form (list
(list 'hidden
:name name
- :value (cdr (assq :value cont))))))))
+ :value (dom-attr dom 'value)))))))
(t
- (eww-form-text cont)))
+ (eww-form-text dom)))
(unless (= start (point))
(put-text-property start (1+ start) 'help-echo "Input field"))))
-(defun eww-tag-select (cont)
+(defun eww-tag-select (dom)
(shr-ensure-paragraph)
- (let ((menu (list :name (cdr (assq :name cont))
+ (let ((menu (list :name (dom-attr dom 'name)
:eww-form eww-form))
(options nil)
(start (point))
(max 0)
opelem)
- (if (eq (car (car cont)) 'optgroup)
- (dolist (groupelem cont)
- (unless (cdr (assq :disabled (cdr groupelem)))
- (setq opelem (append opelem (cdr (cdr groupelem))))))
- (setq opelem cont))
+ (if (eq (dom-tag dom) 'optgroup)
+ (dolist (groupelem (dom-children dom))
+ (unless (dom-attr groupelem 'disabled)
+ (setq opelem (append opelem (list groupelem)))))
+ (setq opelem (list dom)))
(dolist (elem opelem)
- (when (eq (car elem) 'option)
- (when (cdr (assq :selected (cdr elem)))
- (nconc menu (list :value
- (cdr (assq :value (cdr elem))))))
- (let ((display (or (cdr (assq 'text (cdr elem))) "")))
+ (when (eq (dom-tag elem) 'option)
+ (when (dom-attr elem 'selected)
+ (nconc menu (list :value (dom-attr elem 'value))))
+ (let ((display (dom-text elem)))
(setq max (max max (length display)))
(push (list 'item
- :value (cdr (assq :value (cdr elem)))
+ :value (dom-attr elem 'value)
:display display)
options))))
(when options
@@ -897,14 +1171,17 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
(goto-char
(eww-update-field display))))
-(defun eww-update-field (string)
+(defun eww-update-field (string &optional offset)
+ (if (not offset) (setq offset 0))
(let ((properties (text-properties-at (point)))
- (start (eww-beginning-of-field))
- (end (1+ (eww-end-of-field))))
- (delete-region start end)
+ (start (+ (eww-beginning-of-field) offset))
+ (current-end (1+ (eww-end-of-field)))
+ (new-end (1+ (+ (eww-beginning-of-field) (length string)))))
+ (delete-region start current-end)
+ (forward-char offset)
(insert string
- (make-string (- (- end start) (length string)) ? ))
- (set-text-properties start end properties)
+ (make-string (- (- (+ new-end offset) start) (length string)) ? ))
+ (if (= 0 offset) (set-text-properties start new-end properties))
start))
(defun eww-toggle-checkbox ()
@@ -949,6 +1226,18 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
(setq start (next-single-property-change start 'eww-form))))
(nreverse inputs)))
+(defun eww-size-text-inputs ()
+ (let ((start (point-min)))
+ (while (and start
+ (< start (point-max)))
+ (when (or (get-text-property start 'eww-form)
+ (setq start (next-single-property-change start 'eww-form)))
+ (let ((props (get-text-property start 'eww-form)))
+ (plist-put props :start start)
+ (setq start (next-single-property-change
+ start 'eww-form nil (point-max)))
+ (plist-put props :end start))))))
+
(defun eww-input-value (input)
(let ((type (plist-get input :type))
(value (plist-get input :value)))
@@ -972,8 +1261,8 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
(form (plist-get this-input :eww-form))
values next-submit)
(dolist (elem (sort (eww-inputs form)
- (lambda (o1 o2)
- (< (car o1) (car o2)))))
+ (lambda (o1 o2)
+ (< (car o1) (car o2)))))
(let* ((input (cdr elem))
(input-start (car elem))
(name (plist-get input :name)))
@@ -983,6 +1272,16 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
(when (plist-get input :checked)
(push (cons name (plist-get input :value))
values)))
+ ((equal (plist-get input :type) "file")
+ (push (cons "file"
+ (list (cons "filedata"
+ (with-temp-buffer
+ (insert-file-contents
+ (plist-get input :filename))
+ (buffer-string)))
+ (cons "name" (plist-get input :name))
+ (cons "filename" (plist-get input :filename))))
+ values))
((equal (plist-get input :type) "submit")
;; We want the values from buttons if we hit a button if
;; we hit enter on it, or if it's the first button after
@@ -1001,22 +1300,42 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
(when (and (consp elem)
(eq (car elem) 'hidden))
(push (cons (plist-get (cdr elem) :name)
- (plist-get (cdr elem) :value))
+ (or (plist-get (cdr elem) :value) ""))
values)))
(if (and (stringp (cdr (assq :method form)))
(equal (downcase (cdr (assq :method form))) "post"))
- (let ((url-request-method "POST")
- (url-request-extra-headers
- '(("Content-Type" . "application/x-www-form-urlencoded")))
- (url-request-data (mm-url-encode-www-form-urlencoded values)))
- (eww-browse-url (shr-expand-url (cdr (assq :action form))
- eww-current-url)))
+ (let ((mtype))
+ (dolist (x values mtype)
+ (if (equal (car x) "file")
+ (progn
+ (setq mtype "multipart/form-data"))))
+ (cond ((equal mtype "multipart/form-data")
+ (let ((boundary (mml-compute-boundary '())))
+ (let ((url-request-method "POST")
+ (url-request-extra-headers
+ (list (cons "Content-Type"
+ (concat "multipart/form-data; boundary="
+ boundary))))
+ (url-request-data
+ (mm-url-encode-multipart-form-data values boundary)))
+ (eww-browse-url (shr-expand-url
+ (cdr (assq :action form))
+ (plist-get eww-data :url))))))
+ (t
+ (let ((url-request-method "POST")
+ (url-request-extra-headers
+ '(("Content-Type" .
+ "application/x-www-form-urlencoded")))
+ (url-request-data
+ (mm-url-encode-www-form-urlencoded values)))
+ (eww-browse-url (shr-expand-url
+ (cdr (assq :action form))
+ (plist-get eww-data :url)))))))
(eww-browse-url
(concat
(if (cdr (assq :action form))
- (shr-expand-url (cdr (assq :action form))
- eww-current-url)
- eww-current-url)
+ (shr-expand-url (cdr (assq :action form)) (plist-get eww-data :url))
+ (plist-get eww-data :url))
"?"
(mm-url-encode-www-form-urlencoded values))))))
@@ -1024,11 +1343,12 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.")
"Browse the current URL with an external browser.
The browser to used is specified by the `shr-external-browser' variable."
(interactive)
- (funcall shr-external-browser (or url eww-current-url)))
+ (funcall shr-external-browser (or url (plist-get eww-data :url))))
(defun eww-follow-link (&optional external mouse-event)
"Browse the URL under point.
-If EXTERNAL, browse the URL using `shr-external-browser'."
+If EXTERNAL is single prefix, browse the URL using `shr-external-browser'.
+If EXTERNAL is double prefix, browse in new buffer."
(interactive (list current-prefix-arg last-nonmenu-event))
(mouse-set-point mouse-event)
(let ((url (get-text-property (point) 'shr-url)))
@@ -1037,15 +1357,16 @@ If EXTERNAL, browse the URL using `shr-external-browser'."
(message "No link under point"))
((string-match "^mailto:" url)
(browse-url-mail url))
- (external
+ ((and (consp external) (<= (car external) 4))
(funcall shr-external-browser url))
;; This is a #target url in the same page as the current one.
((and (url-target (url-generic-parse-url url))
- (eww-same-page-p url eww-current-url))
- (eww-save-history)
- (eww-display-html 'utf8 url eww-current-dom))
+ (eww-same-page-p url (plist-get eww-data :url)))
+ (let ((dom (plist-get eww-data :dom)))
+ (eww-save-history)
+ (eww-display-html 'utf-8 url dom nil (current-buffer))))
(t
- (eww-browse-url url)))))
+ (eww-browse-url url external)))))
(defun eww-same-page-p (url1 url2)
"Return non-nil if both URLs represent the same page.
@@ -1057,9 +1378,10 @@ Differences in #targets are ignored."
(equal (url-recreate-url obj1) (url-recreate-url obj2))))
(defun eww-copy-page-url ()
+ "Copy the URL of the current page into the kill ring."
(interactive)
- (message "%s" eww-current-url)
- (kill-new eww-current-url))
+ (message "%s" (plist-get eww-data :url))
+ (kill-new (plist-get eww-data :url)))
(defun eww-download ()
"Download URL under point to `eww-download-directory'."
@@ -1075,7 +1397,9 @@ Differences in #targets are ignored."
(path (car (url-path-and-query obj)))
(file (eww-make-unique-file-name (file-name-nondirectory path)
eww-download-directory)))
- (write-file file)
+ (goto-char (point-min))
+ (re-search-forward "\r?\n\r?\n")
+ (write-region (point) (point-max) file)
(message "Saved %s" file))))
(defun eww-make-unique-file-name (file directory)
@@ -1094,42 +1418,50 @@ Differences in #targets are ignored."
(setq count (1+ count)))
(expand-file-name file directory)))
+(defun eww-set-character-encoding (charset)
+ "Set character encoding."
+ (interactive "zUse character set (default utf-8): ")
+ (if (null charset)
+ (eww-reload nil 'utf-8)
+ (eww-reload nil charset)))
+
;;; Bookmarks code
(defvar eww-bookmarks nil)
(defun eww-add-bookmark ()
- "Add the current page to the bookmarks."
+ "Bookmark the current page."
(interactive)
(eww-read-bookmarks)
(dolist (bookmark eww-bookmarks)
- (when (equal eww-current-url
- (plist-get bookmark :url))
+ (when (equal (plist-get eww-data :url) (plist-get bookmark :url))
(user-error "Already bookmarked")))
- (if (y-or-n-p "bookmark this page? ")
- (progn
- (let ((title (replace-regexp-in-string "[\n\t\r]" " " eww-current-title)))
- (setq title (replace-regexp-in-string "\\` +\\| +\\'" "" title))
- (push (list :url eww-current-url
- :title title
- :time (current-time-string))
- eww-bookmarks))
- (eww-write-bookmarks)
- (message "Bookmarked %s (%s)" eww-current-url eww-current-title))))
+ (when (y-or-n-p "Bookmark this page?")
+ (let ((title (replace-regexp-in-string "[\n\t\r]" " "
+ (plist-get eww-data :title))))
+ (setq title (replace-regexp-in-string "\\` +\\| +\\'" "" title))
+ (push (list :url (plist-get eww-data :url)
+ :title title
+ :time (current-time-string))
+ eww-bookmarks))
+ (eww-write-bookmarks)
+ (message "Bookmarked %s (%s)" (plist-get eww-data :url)
+ (plist-get eww-data :title))))
(defun eww-write-bookmarks ()
- (with-temp-file (expand-file-name "eww-bookmarks" user-emacs-directory)
+ (with-temp-file (expand-file-name "eww-bookmarks" eww-bookmarks-directory)
(insert ";; Auto-generated file; don't edit\n")
(pp eww-bookmarks (current-buffer))))
(defun eww-read-bookmarks ()
- (let ((file (expand-file-name "eww-bookmarks" user-emacs-directory)))
+ (let ((file (expand-file-name "eww-bookmarks" eww-bookmarks-directory)))
(setq eww-bookmarks
(unless (zerop (or (nth 7 (file-attributes file)) 0))
(with-temp-buffer
(insert-file-contents file)
(read (current-buffer)))))))
+;;;###autoload
(defun eww-list-bookmarks ()
"Display the bookmarks."
(interactive)
@@ -1142,19 +1474,18 @@ Differences in #targets are ignored."
(user-error "No bookmarks are defined"))
(set-buffer (get-buffer-create "*eww bookmarks*"))
(eww-bookmark-mode)
- (let ((format "%-40s %s")
- (inhibit-read-only t)
- start url)
+ (let* ((width (/ (window-width) 2))
+ (format (format "%%-%ds %%s" width))
+ (inhibit-read-only t)
+ start title)
(erase-buffer)
- (setq header-line-format (concat " " (format format "URL" "Title")))
+ (setq header-line-format (concat " " (format format "Title" "URL")))
(dolist (bookmark eww-bookmarks)
- (setq start (point))
- (setq url (plist-get bookmark :url))
- (when (> (length url) 40)
- (setq url (substring url 0 40)))
- (insert (format format url
- (plist-get bookmark :title))
- "\n")
+ (setq start (point)
+ title (plist-get bookmark :title))
+ (when (> (length title) width)
+ (setq title (substring title 0 width)))
+ (insert (format format title (plist-get bookmark :url)) "\n")
(put-text-property start (1+ start) 'eww-bookmark bookmark))
(goto-char (point-min))))
@@ -1272,22 +1603,28 @@ Differences in #targets are ignored."
;;; History code
(defun eww-save-history ()
- (push (list :url eww-current-url
- :title eww-current-title
- :point (point)
- :dom eww-current-dom
- :source eww-current-source
- :text (buffer-string))
- eww-history))
+ (plist-put eww-data :point (point))
+ (plist-put eww-data :text (buffer-string))
+ (push eww-data eww-history)
+ (setq eww-data (list :title ""))
+ ;; Don't let the history grow infinitely. We store quite a lot of
+ ;; data per page.
+ (when-let (tail (and eww-history-limit
+ (nthcdr eww-history-limit eww-history)))
+ (setcdr tail nil)))
+
+(defvar eww-current-buffer)
(defun eww-list-histories ()
"List the eww-histories."
(interactive)
(when (null eww-history)
(error "No eww-histories are defined"))
- (let ((eww-history-trans eww-history))
+ (let ((eww-history-trans eww-history)
+ (buffer (current-buffer)))
(set-buffer (get-buffer-create "*eww history*"))
(eww-history-mode)
+ (setq-local eww-current-buffer buffer)
(let ((inhibit-read-only t)
(domain-length 0)
(title-length 0)
@@ -1316,7 +1653,10 @@ Differences in #targets are ignored."
(let ((history (get-text-property (line-beginning-position) 'eww-history)))
(unless history
(error "No history on the current line"))
- (quit-window)
+ (let ((buffer eww-current-buffer))
+ (quit-window)
+ (when buffer
+ (switch-to-buffer buffer)))
(eww-restore-history history)))
(defvar eww-history-mode-map
@@ -1343,6 +1683,223 @@ Differences in #targets are ignored."
(setq buffer-read-only t
truncate-lines t))
+;;; eww buffers list
+
+(defun eww-list-buffers ()
+ "Enlist eww buffers."
+ (interactive)
+ (let (buffers-info
+ (current (current-buffer)))
+ (dolist (buffer (buffer-list))
+ (with-current-buffer buffer
+ (when (derived-mode-p 'eww-mode)
+ (push (vector buffer (plist-get eww-data :title)
+ (plist-get eww-data :url))
+ buffers-info))))
+ (unless buffers-info
+ (error "No eww buffers"))
+ (setq buffers-info (nreverse buffers-info)) ;more recent on top
+ (set-buffer (get-buffer-create "*eww buffers*"))
+ (eww-buffers-mode)
+ (let ((inhibit-read-only t)
+ (domain-length 0)
+ (title-length 0)
+ url title format start)
+ (erase-buffer)
+ (dolist (buffer-info buffers-info)
+ (setq title-length (max title-length
+ (length (elt buffer-info 1)))
+ domain-length (max domain-length
+ (length (elt buffer-info 2)))))
+ (setq format (format "%%-%ds %%-%ds" title-length domain-length)
+ header-line-format
+ (concat " " (format format "Title" "URL")))
+ (let ((line 0)
+ (current-buffer-line 1))
+ (dolist (buffer-info buffers-info)
+ (setq start (point)
+ title (elt buffer-info 1)
+ url (elt buffer-info 2)
+ line (1+ line))
+ (insert (format format title url))
+ (insert "\n")
+ (let ((buffer (elt buffer-info 0)))
+ (put-text-property start (1+ start) 'eww-buffer
+ buffer)
+ (when (eq current buffer)
+ (setq current-buffer-line line))))
+ (goto-char (point-min))
+ (forward-line (1- current-buffer-line)))))
+ (pop-to-buffer "*eww buffers*"))
+
+(defun eww-buffer-select ()
+ "Switch to eww buffer."
+ (interactive)
+ (let ((buffer (get-text-property (line-beginning-position)
+ 'eww-buffer)))
+ (unless buffer
+ (error "No buffer on current line"))
+ (quit-window)
+ (switch-to-buffer buffer)))
+
+(defun eww-buffer-show ()
+ "Display buffer under point in eww buffer list."
+ (let ((buffer (get-text-property (line-beginning-position)
+ 'eww-buffer)))
+ (unless buffer
+ (error "No buffer on current line"))
+ (other-window -1)
+ (switch-to-buffer buffer)
+ (other-window 1)))
+
+(defun eww-buffer-show-next ()
+ "Move to next eww buffer in the list and display it."
+ (interactive)
+ (forward-line)
+ (when (eobp)
+ (goto-char (point-min)))
+ (eww-buffer-show))
+
+(defun eww-buffer-show-previous ()
+ "Move to previous eww buffer in the list and display it."
+ (interactive)
+ (beginning-of-line)
+ (when (bobp)
+ (goto-char (point-max)))
+ (forward-line -1)
+ (eww-buffer-show))
+
+(defun eww-buffer-kill ()
+ "Kill buffer from eww list."
+ (interactive)
+ (let* ((start (line-beginning-position))
+ (buffer (get-text-property start 'eww-buffer))
+ (inhibit-read-only t))
+ (unless buffer
+ (user-error "No buffer on the current line"))
+ (kill-buffer buffer)
+ (forward-line 1)
+ (delete-region start (point)))
+ (when (eobp)
+ (forward-line -1))
+ (eww-buffer-show))
+
+(defvar eww-buffers-mode-map
+ (let ((map (make-sparse-keymap)))
+ (suppress-keymap map)
+ (define-key map "q" 'quit-window)
+ (define-key map [(control k)] 'eww-buffer-kill)
+ (define-key map "\r" 'eww-buffer-select)
+ (define-key map "n" 'eww-buffer-show-next)
+ (define-key map "p" 'eww-buffer-show-previous)
+
+ (easy-menu-define nil map
+ "Menu for `eww-buffers-mode-map'."
+ '("Eww Buffers"
+ ["Exit" quit-window t]
+ ["Select" eww-buffer-select
+ :active (get-text-property (line-beginning-position) 'eww-buffer)]
+ ["Kill" eww-buffer-kill
+ :active (get-text-property (line-beginning-position) 'eww-buffer)]))
+ map))
+
+(define-derived-mode eww-buffers-mode nil "eww buffers"
+ "Mode for listing buffers.
+
+\\{eww-buffers-mode-map}"
+ (buffer-disable-undo)
+ (setq buffer-read-only t
+ truncate-lines t))
+
+;;; Desktop support
+
+(defvar eww-desktop-data-save
+ '(:url :title :point)
+ "List of `eww-data' properties to preserve in the desktop file.
+Also used when saving `eww-history'.")
+
+(defun eww-desktop-data-1 (alist)
+ (let ((acc nil)
+ (tail alist))
+ (while tail
+ (let ((k (car tail))
+ (v (cadr tail)))
+ (when (memq k eww-desktop-data-save)
+ (setq acc (cons k (cons v acc)))))
+ (setq tail (cddr tail)))
+ acc))
+
+(defun eww-desktop-history-duplicate (a b)
+ (let ((tail a) (r t))
+ (while tail
+ (if (or (memq (car tail) '(:point)) ; ignore :point
+ (equal (cadr tail)
+ (plist-get b (car tail))))
+ (setq tail (cddr tail))
+ (setq tail nil
+ r nil)))
+ ;; .
+ r))
+
+(defun eww-desktop-misc-data (_directory)
+ "Return a property list with data used to restore eww buffers.
+This list will contain, as :history, the list, whose first element is
+the value of `eww-data', and the tail is `eww-history'.
+
+If `eww-desktop-remove-duplicates' is non-nil, duplicate
+entries (if any) will be removed from the list.
+
+Only the properties listed in `eww-desktop-data-save' are included.
+Generally, the list should not include the (usually overly large)
+:dom, :source and :text properties."
+ (let ((history (mapcar 'eww-desktop-data-1
+ (cons eww-data eww-history))))
+ (list :history (if eww-desktop-remove-duplicates
+ (cl-remove-duplicates
+ history :test 'eww-desktop-history-duplicate)
+ history))))
+
+(defun eww-restore-desktop (file-name buffer-name misc-data)
+ "Restore an eww buffer from its desktop file record.
+If `eww-restore-desktop' is t or 'auto, this function will also
+initiate the retrieval of the respective URI in the background.
+Otherwise, the restored buffer will contain a prompt to do so by using
+\\[eww-reload]."
+ (with-current-buffer (get-buffer-create buffer-name)
+ (eww-mode)
+ ;; NB: eww-history, eww-data are buffer-local per (eww-mode)
+ (setq eww-history (cdr (plist-get misc-data :history))
+ eww-data (or (car (plist-get misc-data :history))
+ ;; backwards compatibility
+ (list :url (plist-get misc-data :uri))))
+ (unless file-name
+ (when (plist-get eww-data :url)
+ (case eww-restore-desktop
+ ((t auto) (eww (plist-get eww-data :url)))
+ ((zerop (buffer-size))
+ (insert (substitute-command-keys
+ eww-restore-reload-prompt))))))
+ ;; .
+ (current-buffer)))
+
+(add-to-list 'desktop-locals-to-save
+ 'eww-history-position)
+(add-to-list 'desktop-buffer-mode-handlers
+ '(eww-mode . eww-restore-desktop))
+
+;;; Isearch support
+
+(defun eww-isearch-next-buffer (&optional _buffer wrap)
+ "Go to the next page to search using `rel' attribute for navigation."
+ (if wrap
+ (condition-case nil
+ (eww-top-url)
+ (error nil))
+ (if isearch-forward
+ (eww-next-url)
+ (eww-previous-url)))
+ (current-buffer))
+
(provide 'eww)
;;; eww.el ends here
diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el
index 0593c1f29e3..235b2a2a111 100644
--- a/lisp/net/gnutls.el
+++ b/lisp/net/gnutls.el
@@ -41,7 +41,7 @@
"Emacs interface to the GnuTLS library."
:version "24.1"
:prefix "gnutls-"
- :group 'net-utils)
+ :group 'comm)
(defcustom gnutls-algorithm-priority nil
"If non-nil, this should be a TLS priority string.
@@ -189,6 +189,9 @@ here's a recent version of the list.
It must be omitted, a number, or nil; if omitted or nil it
defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT."
(let* ((type (or type 'gnutls-x509pki))
+ ;; The gnutls library doesn't understand files delivered via
+ ;; the special handlers, so ignore all files found via those.
+ (file-name-handler-alist nil)
(trustfiles (or trustfiles
(delq nil
(mapcar (lambda (f) (and f (file-exists-p f) f))
@@ -211,11 +214,13 @@ defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT."
t)
;; if a list, look for hostname matches
((listp gnutls-verify-error)
- (cl-mapcan
- (lambda (check)
- (when (string-match (car check) hostname)
- (cdr check)))
- gnutls-verify-error))
+ (apply 'append
+ (mapcar
+ (lambda (check)
+ (when (string-match (nth 0 check)
+ hostname)
+ (nth 1 check)))
+ gnutls-verify-error)))
;; else it's nil
(t nil))))
(min-prime-bits (or min-prime-bits gnutls-min-prime-bits))
diff --git a/lisp/net/ldap.el b/lisp/net/ldap.el
index eb1b7589b48..a77fc3c6514 100644
--- a/lisp/net/ldap.el
+++ b/lisp/net/ldap.el
@@ -34,6 +34,7 @@
;;; Code:
(require 'custom)
+(require 'password-cache)
(autoload 'auth-source-search "auth-source")
@@ -47,15 +48,13 @@
A TCP port number can be appended to that name using a colon as
a separator."
:type '(choice (string :tag "Host name")
- (const :tag "Use library default" nil))
- :group 'ldap)
+ (const :tag "Use library default" nil)))
(defcustom ldap-default-port nil
"Default TCP port for LDAP connections.
Initialized from the LDAP library at build time. Default value is 389."
:type '(choice (const :tag "Use library default" nil)
- (integer :tag "Port number"))
- :group 'ldap)
+ (integer :tag "Port number")))
(defcustom ldap-default-base nil
"Default base for LDAP searches.
@@ -63,8 +62,7 @@ This is a string using the syntax of RFC 1779.
For instance, \"o=ACME, c=US\" limits the search to the
Acme organization in the United States."
:type '(choice (const :tag "Use library default" nil)
- (string :tag "Search base"))
- :group 'ldap)
+ (string :tag "Search base")))
(defcustom ldap-host-parameters-alist nil
@@ -144,35 +142,35 @@ Valid properties include:
:tag "Size Limit"
:inline t
(const :tag "Size Limit" sizelimit)
- (integer :tag "(number of records)")))))
- :group 'ldap)
+ (integer :tag "(number of records)"))))))
(defcustom ldap-ldapsearch-prog "ldapsearch"
"The name of the ldapsearch command line program."
- :type '(string :tag "`ldapsearch' Program")
- :group 'ldap)
+ :type '(string :tag "`ldapsearch' Program"))
(defcustom ldap-ldapsearch-args '("-LL" "-tt")
"A list of additional arguments to pass to `ldapsearch'."
:type '(repeat :tag "`ldapsearch' Arguments"
- (string :tag "Argument"))
- :group 'ldap)
+ (string :tag "Argument")))
+
+(defcustom ldap-ldapsearch-password-prompt-regexp "Enter LDAP Password: "
+ "A regular expression used to recognize the `ldapsearch'
+program's password prompt."
+ :type 'regexp
+ :version "25.1")
(defcustom ldap-ignore-attribute-codings nil
"If non-nil, do not encode/decode LDAP attribute values."
- :type 'boolean
- :group 'ldap)
+ :type 'boolean)
(defcustom ldap-default-attribute-decoder nil
"Decoder function to use for attributes whose syntax is unknown."
- :type 'symbol
- :group 'ldap)
+ :type 'symbol)
(defcustom ldap-coding-system 'utf-8
"Coding system of LDAP string values.
LDAP v3 specifies the coding system of strings to be UTF-8."
- :type 'symbol
- :group 'ldap)
+ :type 'symbol)
(defvar ldap-attribute-syntax-encoders
[nil ; 1 ACI Item N
@@ -476,6 +474,47 @@ Additional search parameters can be specified through
(mapcar 'ldap-decode-attribute record))
result))))
+(defun ldap-password-read (host)
+ "Read LDAP password for HOST.
+If the password is cached, it is read from the cache, otherwise the user
+is prompted for the password. If `password-cache' is non-nil the password
+is verified and cached. The `password-cache-expiry' variable
+controls for how long the password is cached.
+
+This function can be specified for the `passwd' property in
+`ldap-host-parameters-alist' when interactive password prompting
+is desired for HOST."
+ ;; Add ldap: namespace to allow empty string for default host.
+ (let* ((host-key (concat "ldap:" host))
+ (password (password-read
+ (format "Enter LDAP Password%s: "
+ (if (equal host "")
+ ""
+ (format " for %s" host)))
+ host-key)))
+ (when (and password-cache
+ (not (password-in-cache-p host-key))
+ ;; Confirm the password is valid before adding it to
+ ;; the password cache. ldap-search-internal will throw
+ ;; an error if the password is invalid.
+ (not (ldap-search-internal
+ `(host ,host
+ ;; Specify an arbitrary filter that should
+ ;; produce no results, since only
+ ;; authentication success is of interest.
+ filter "emacs-test-password="
+ attributes nil
+ attrsonly nil
+ withdn nil
+ ;; Preempt passwd ldap-password-read
+ ;; setting in ldap-host-parameters-alist.
+ passwd ,password
+ ,@(cdr
+ (assoc
+ host
+ ldap-host-parameters-alist))))))
+ (password-cache-add host-key password))
+ password))
(defun ldap-search-internal (search-plist)
"Perform a search on a LDAP server.
@@ -531,7 +570,11 @@ an alist of attribute/value pairs."
(passwd (or (plist-get search-plist 'passwd)
(plist-get asfound :secret)))
;; convert the password from a function call if needed
- (passwd (if (functionp passwd) (funcall passwd) passwd))
+ (passwd (if (functionp passwd)
+ (if (eq passwd 'ldap-password-read)
+ (funcall passwd host)
+ (funcall passwd))
+ passwd))
;; get the binddn from the search-list or from the
;; auth-source user or binddn tokens
(binddn (or (plist-get search-plist 'binddn)
@@ -550,7 +593,7 @@ an alist of attribute/value pairs."
(sizelimit (plist-get search-plist 'sizelimit))
(withdn (plist-get search-plist 'withdn))
(numres 0)
- arglist dn name value record result)
+ arglist dn name value record result proc)
(if (or (null filter)
(equal "" filter))
(error "No search filter"))
@@ -559,7 +602,13 @@ an alist of attribute/value pairs."
(erase-buffer)
(if (and host
(not (equal "" host)))
- (setq arglist (nconc arglist (list (format "-h%s" host)))))
+ (setq arglist (nconc arglist
+ (list (format
+ ;; Use -H if host is a new-style LDAP URI.
+ (if (string-match "^[a-zA-Z]+://" host)
+ "-H%s"
+ "-h%s")
+ host)))))
(if (and attrsonly
(not (equal "" attrsonly)))
(setq arglist (nconc arglist (list "-A"))))
@@ -575,9 +624,9 @@ an alist of attribute/value pairs."
(if (and auth
(equal 'simple auth))
(setq arglist (nconc arglist (list "-x"))))
- (if (and passwd
- (not (equal "" passwd)))
- (setq arglist (nconc arglist (list (format "-w%s" passwd)))))
+ ;; Allow passwd to be set to "", representing a blank password.
+ (if passwd
+ (setq arglist (nconc arglist (list "-W"))))
(if (and deref
(not (equal "" deref)))
(setq arglist (nconc arglist (list (format "-a%s" deref)))))
@@ -587,14 +636,43 @@ an alist of attribute/value pairs."
(if (and sizelimit
(not (equal "" sizelimit)))
(setq arglist (nconc arglist (list (format "-z%s" sizelimit)))))
- (apply #'call-process ldap-ldapsearch-prog
- ;; Ignore stderr, which can corrupt results
- nil (list buf nil) nil
- (append arglist ldap-ldapsearch-args filter))
+ (if passwd
+ (let* ((process-connection-type nil)
+ (proc-args (append arglist ldap-ldapsearch-args
+ filter))
+ (proc (apply #'start-process "ldapsearch" buf
+ ldap-ldapsearch-prog
+ proc-args)))
+ (while (null (progn
+ (goto-char (point-min))
+ (re-search-forward
+ ldap-ldapsearch-password-prompt-regexp
+ (point-max) t)))
+ (accept-process-output proc 1))
+ (process-send-string proc passwd)
+ (process-send-string proc "\n")
+ (while (not (memq (process-status proc) '(exit signal)))
+ (sit-for 0.1))
+ (let ((status (process-exit-status proc)))
+ (when (not (eq status 0))
+ ;; Handle invalid credentials exit status specially
+ ;; for ldap-password-read.
+ (if (eq status 49)
+ (error (concat "Incorrect LDAP password or"
+ " bind distinguished name (binddn)"))
+ (error "Failed ldapsearch invocation: %s \"%s\""
+ ldap-ldapsearch-prog
+ (mapconcat 'identity proc-args "\" \""))))))
+ (apply #'call-process ldap-ldapsearch-prog
+ ;; Ignore stderr, which can corrupt results
+ nil (list buf nil) nil
+ (append arglist ldap-ldapsearch-args filter)))
(insert "\n")
(goto-char (point-min))
- (while (re-search-forward "[\t\n\f]+ " nil t)
+ (while (re-search-forward (concat "[\t\n\f]+ \\|"
+ ldap-ldapsearch-password-prompt-regexp)
+ nil t)
(replace-match "" nil nil))
(goto-char (point-min))
diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el
index ea03bc65499..e7b3150b792 100644
--- a/lisp/net/network-stream.el
+++ b/lisp/net/network-stream.el
@@ -45,6 +45,7 @@
(require 'tls)
(require 'starttls)
(require 'auth-source)
+(require 'nsm)
(autoload 'gnutls-negotiate "gnutls")
(autoload 'open-gnutls-stream "gnutls")
@@ -128,11 +129,14 @@ values:
:use-starttls-if-possible is a boolean that says to do opportunistic
STARTTLS upgrades even if Emacs doesn't have built-in TLS functionality.
+:warn-unless-encrypted is a boolean which, if :return-list is
+non-nil, is used warn the user if the connection isn't encrypted.
+
:nogreeting is a boolean that can be used to inhibit waiting for
a greeting from the server.
:nowait is a boolean that says the connection should be made
- asynchronously, if possible."
+asynchronously, if possible."
(unless (featurep 'make-network-process)
(error "Emacs was compiled without networking support"))
(let ((type (plist-get parameters :type))
@@ -196,6 +200,8 @@ a greeting from the server.
(stream (make-network-process :name name :buffer buffer
:host host :service service
:nowait (plist-get parameters :nowait))))
+ (when (plist-get parameters :warn-unless-encrypted)
+ (setq stream (nsm-verify-connection stream host service nil t)))
(list stream
(network-stream-get-response stream start
(plist-get parameters :end-of-command))
@@ -219,8 +225,6 @@ a greeting from the server.
(capabilities (network-stream-command stream capability-command
eo-capa))
(resulting-type 'plain)
- (builtin-starttls (and (fboundp 'gnutls-available-p)
- (gnutls-available-p)))
starttls-available starttls-command error)
;; First check whether the server supports STARTTLS at all.
@@ -231,14 +235,14 @@ a greeting from the server.
;; connection.
(when (and starttls-command
(setq starttls-available
- (or builtin-starttls
+ (or (gnutls-available-p)
(and (or require-tls
(plist-get parameters :use-starttls-if-possible))
(starttls-available-p))))
(not (eq (plist-get parameters :type) 'plain)))
;; If using external STARTTLS, drop this connection and start
;; anew with `starttls-open-stream'.
- (unless builtin-starttls
+ (unless (gnutls-available-p)
(delete-process stream)
(setq start (with-current-buffer buffer (point-max)))
(let* ((starttls-extra-arguments
@@ -271,7 +275,7 @@ a greeting from the server.
(network-stream-command stream starttls-command eoc)))
(and response (string-match success-string response)))
;; The server said it was OK to begin STARTTLS negotiations.
- (if builtin-starttls
+ (if (gnutls-available-p)
(let ((cert (network-stream-certificate host service parameters)))
(condition-case nil
(gnutls-negotiate :process stream :hostname host
@@ -319,6 +323,12 @@ a greeting from the server.
"' program was found"))))
(delete-process stream)
(setq stream nil))
+ ;; Check certificate validity etc.
+ (when (gnutls-available-p)
+ (setq stream (nsm-verify-connection
+ stream host service
+ (eq resulting-type 'tls)
+ (plist-get parameters :warn-unless-encrypted))))
;; Return value:
(list stream greeting capabilities resulting-type error)))
@@ -344,19 +354,20 @@ a greeting from the server.
(defun network-stream-open-tls (name buffer host service parameters)
(with-current-buffer buffer
(let* ((start (point-max))
- (use-builtin-gnutls (and (fboundp 'gnutls-available-p)
- (gnutls-available-p)))
(stream
- (funcall (if use-builtin-gnutls
+ (funcall (if (gnutls-available-p)
'open-gnutls-stream
'open-tls-stream)
name buffer host service))
(eoc (plist-get parameters :end-of-command)))
+ ;; Check certificate validity etc.
+ (when (and (gnutls-available-p) stream)
+ (setq stream (nsm-verify-connection stream host service)))
(if (null stream)
(list nil nil nil 'plain)
;; If we're using tls.el, we have to delete the output from
;; openssl/gnutls-cli.
- (when (and (null use-builtin-gnutls)
+ (when (and (not (gnutls-available-p))
eoc)
(network-stream-get-response stream start eoc)
(goto-char (point-min))
diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el
index 6dddf078fcd..5db04eb6745 100644
--- a/lisp/net/newst-backend.el
+++ b/lisp/net/newst-backend.el
@@ -6,7 +6,6 @@
;; Filename: newst-backend.el
;; URL: http://www.nongnu.org/newsticker
;; Keywords: News, RSS, Atom
-;; Time-stamp: "13. Mai 2011, 20:47:05 (ulf)"
;; Package: newsticker
;; ======================================================================
@@ -37,6 +36,7 @@
(require 'derived)
(require 'xml)
+(require 'url-parse)
;; Silence warnings
(defvar w3-mode-map)
@@ -47,9 +47,6 @@
"List of timers for news retrieval.
This is an alist, each element consisting of (feed-name . timer).")
-(defvar newsticker--download-logos nil
- "If non-nil download feed logos if available.")
-
(defvar newsticker--sentinel-callback nil
"Function called at end of `newsticker--sentinel'.")
@@ -483,14 +480,6 @@ that can be added."
;; ======================================================================
;;; Internal variables
;; ======================================================================
-(defvar newsticker--item-list nil
- "List of newsticker items.")
-(defvar newsticker--item-position 0
- "Actual position in list of newsticker items.")
-(defvar newsticker--prev-message "There was no previous message yet!"
- "Last message that the newsticker displayed.")
-(defvar newsticker--scrollable-text ""
- "The text which is scrolled smoothly in the echo area.")
(defvar newsticker--buffer-uptodate-p nil
"Tells whether the newsticker buffer is up to date.")
(defvar newsticker--latest-update-time (current-time)
@@ -756,10 +745,14 @@ from."
(insert result)
;; remove MIME header
(goto-char (point-min))
- (search-forward "\n\n")
+ (search-forward "\n\n" nil t)
(delete-region (point-min) (point))
;; read the rss/atom contents
- (newsticker--sentinel-work nil t feed-name "url-retrieve" (current-buffer))
+ (newsticker--sentinel-work nil
+ (or (not status)
+ (not (eq (car status) :error)))
+ feed-name "url-retrieve"
+ (current-buffer))
(when status
(let ((status-type (car status))
(status-details (cdr status)))
@@ -768,7 +761,7 @@ from."
)
((eq status-type :error)
(message "%s: Error while retrieving news from %s: %s: \"%s\""
- (format-time-string "%A, %H:%M" (current-time))
+ (format-time-string "%A, %H:%M")
feed-name
(car status-details) (cdr status-details))))))))
@@ -788,6 +781,7 @@ See `newsticker-get-news'."
newsticker-wget-name args)))
(set-process-coding-system proc 'no-conversion 'no-conversion)
(set-process-sentinel proc 'newsticker--sentinel)
+ (process-put proc 'nt-feed-name feed-name)
(setq newsticker--process-ids (cons (process-id proc)
newsticker--process-ids))
(force-mode-line-update)))))
@@ -797,7 +791,7 @@ See `newsticker-get-news'."
FEED-NAME must be a string which occurs as the label (i.e. the first element)
in an element of `newsticker-url-list' or `newsticker-url-list-defaults'."
(newsticker--debug-msg "%s: Getting news for %s"
- (format-time-string "%A, %H:%M" (current-time))
+ (format-time-string "%A, %H:%M")
feed-name)
(let* ((item (or (assoc feed-name newsticker-url-list)
(assoc feed-name newsticker-url-list-defaults)
@@ -823,25 +817,26 @@ Argument PROCESS is the process which has just changed its state.
Argument EVENT tells what has happened to the process."
(let ((p-status (process-status process))
(exit-status (process-exit-status process))
- (name (process-name process))
+ (feed-name (process-get process 'nt-feed-name))
(command (process-command process))
(buffer (process-buffer process)))
(newsticker--sentinel-work event
(and (eq p-status 'exit)
(= exit-status 0))
- name command buffer)))
+ feed-name command buffer)))
-(defun newsticker--sentinel-work (event status-ok name command buffer)
+(defun newsticker--sentinel-work (event status-ok feed-name command buffer)
"Actually do the sentinel work.
Argument EVENT tells what has happened to the retrieval process.
Argument STATUS-OK is the final status of the retrieval process,
non-nil meaning retrieval was successful.
-Argument NAME is the name of the retrieval process.
+Argument FEED-NAME is the name of the retrieved feed.
Argument COMMAND is the command of the retrieval process.
Argument BUFFER is the buffer of the retrieval process."
(let ((time (current-time))
- (name-symbol (intern name))
- (something-was-added nil))
+ (name-symbol (intern feed-name))
+ (something-was-added nil)
+ (ct (current-time)))
;; catch known errors (zombie processes, rubbish-xml etc.
;; if an error occurs the news feed is not updated!
(catch 'oops
@@ -855,73 +850,26 @@ Argument BUFFER is the buffer of the retrieval process."
(concat "%s: Newsticker could not retrieve news from %s.\n"
"Return status: `%s'\n"
"Command was `%s'")
- (format-time-string "%A, %H:%M" (current-time))
- name event command)
+ (format-time-string "%A, %H:%M")
+ feed-name event command)
""
- (current-time)
+ ct
'new
- 0 nil))
+ 0 '((guid nil "newsticker--download-error"))
+ ct))
(message "%s: Error while retrieving news from %s"
- (format-time-string "%A, %H:%M" (current-time))
- name)
+ (format-time-string "%A, %H:%M")
+ feed-name)
(throw 'oops nil))
(let* ((coding-system 'utf-8)
(node-list
(save-current-buffer
(set-buffer buffer)
- ;; a very very dirty workaround to overcome the
- ;; problems with the newest (20030621) xml.el:
- ;; remove all unnecessary whitespace
- (goto-char (point-min))
- (while (re-search-forward ">[ \t\r\n]+<" nil t)
- (replace-match "><" nil t))
- ;; and another brutal workaround (20031105)! For some
- ;; reason the xml parser does not like the colon in the
- ;; doctype name "rdf:RDF"
- (goto-char (point-min))
- (if (re-search-forward "<!DOCTYPE[ \t\n]+rdf:RDF" nil t)
- (replace-match "<!DOCTYPE rdfColonRDF" nil t))
- ;; finally.... ~##^°!!!!!
- (goto-char (point-min))
- (while (search-forward "\r\n" nil t)
- (replace-match "\n" nil t))
- ;; still more brutal workarounds (20040309)! The xml
- ;; parser does not like doctype rss
- (goto-char (point-min))
- (if (re-search-forward "<!DOCTYPE[ \t\n]+rss[ \t\n]*>" nil t)
- (replace-match "" nil t))
- ;; And another one (20050618)! (Fixed in GNU Emacs 22.0.50.18)
- ;; Remove comments to avoid this xml-parsing bug:
- ;; "XML files can have only one toplevel tag"
- (goto-char (point-min))
- (while (search-forward "<!--" nil t)
- (let ((start (match-beginning 0)))
- (unless (search-forward "-->" nil t)
- (error "Can't find end of comment"))
- (delete-region start (point))))
- ;; And another one (20050702)! If description is HTML
- ;; encoded and starts with a `<', wrap the whole
- ;; description in a CDATA expression. This happened for
- ;; http://www.thefreedictionary.com/_/WoD/rss.aspx?type=quote
- (goto-char (point-min))
- (while (re-search-forward
- "<description>\\(<img.*?\\)</description>" nil t)
- (replace-match
- "<description><![CDATA[ \\1 ]]></description>"))
- ;; And another one (20051123)! XML parser does not
- ;; like this: <yweather:location city="Frankfurt/Main"
- ;; region="" country="GM" />
- ;; try to "fix" empty attributes
- ;; This happened for
- ;; http://xml.weather.yahoo.com/forecastrss?p=GMXX0040&u=f
- (goto-char (point-min))
- (while (re-search-forward "\\(<[^>]*\\)=\"\"" nil t)
- (replace-match "\\1=\" \""))
- ;;
- (set-buffer-modified-p nil)
+ (unless (fboundp 'libxml-parse-xml-region)
+ (newsticker--do-xml-workarounds))
;; check coding system
(goto-char (point-min))
- (if (re-search-forward "encoding=\"\\([^\"]+\\)\""
+ (if (re-search-forward "encoding=['\"]\\([^\"]+?\\)['\"]"
nil t)
(setq coding-system (intern (downcase (match-string 1))))
(setq coding-system
@@ -930,22 +878,25 @@ Argument BUFFER is the buffer of the retrieval process."
(coding-system-error
(message
"newsticker.el: ignoring coding system %s for %s"
- coding-system name)
+ coding-system feed-name)
nil))))
;; Decode if possible
(when coding-system
(decode-coding-region (point-min) (point-max)
coding-system))
(condition-case errordata
- ;; The xml parser might fail
- ;; or the xml might be bugged
- (xml-parse-region (point-min) (point-max))
+ ;; The xml parser might fail or the xml might be
+ ;; bugged
+ (if (fboundp 'libxml-parse-xml-region)
+ (list (libxml-parse-xml-region (point-min) (point-max)
+ nil t))
+ (xml-parse-region (point-min) (point-max)))
(error (message "Could not parse %s: %s"
(buffer-name) (cadr errordata))
(throw 'oops nil)))))
(topnode (car node-list))
- (channelnode (car (xml-get-children topnode 'channel)))
- (imageurl nil))
+ (image-url nil)
+ (icon-url nil))
;; mark all items as obsolete
(newsticker--cache-replace-age newsticker--cache
name-symbol
@@ -963,41 +914,51 @@ Argument BUFFER is the buffer of the retrieval process."
;; RSS 0.91
((and (eq 'rss (xml-node-name topnode))
(string= "0.91" (xml-get-attribute topnode 'version)))
- (setq imageurl (newsticker--get-logo-url-rss-0.91 topnode))
- (newsticker--parse-rss-0.91 name time topnode))
+ (setq image-url (newsticker--get-logo-url-rss-0.91 topnode))
+ (newsticker--parse-rss-0.91 feed-name time topnode))
;; RSS 0.92
((and (eq 'rss (xml-node-name topnode))
(string= "0.92" (xml-get-attribute topnode 'version)))
- (setq imageurl (newsticker--get-logo-url-rss-0.92 topnode))
- (newsticker--parse-rss-0.92 name time topnode))
+ (setq image-url (newsticker--get-logo-url-rss-0.92 topnode))
+ (newsticker--parse-rss-0.92 feed-name time topnode))
;; RSS 1.0
- ((eq 'rdf:RDF (xml-node-name topnode))
- (setq imageurl (newsticker--get-logo-url-rss-1.0 topnode))
- (newsticker--parse-rss-1.0 name time topnode))
+ ((or (eq 'RDF (xml-node-name topnode))
+ (eq 'rdf:RDF (xml-node-name topnode)))
+ (setq image-url (newsticker--get-logo-url-rss-1.0 topnode))
+ (newsticker--parse-rss-1.0 feed-name time topnode))
;; RSS 2.0
((and (eq 'rss (xml-node-name topnode))
(string= "2.0" (xml-get-attribute topnode 'version)))
- (setq imageurl (newsticker--get-logo-url-rss-2.0 topnode))
- (newsticker--parse-rss-2.0 name time topnode))
+ (setq image-url (newsticker--get-logo-url-rss-2.0 topnode))
+ (newsticker--parse-rss-2.0 feed-name time topnode))
;; Atom 0.3
((and (eq 'feed (xml-node-name topnode))
(string= "http://purl.org/atom/ns#"
(xml-get-attribute topnode 'xmlns)))
- (setq imageurl (newsticker--get-logo-url-atom-0.3 topnode))
- (newsticker--parse-atom-0.3 name time topnode))
+ (setq image-url (newsticker--get-logo-url-atom-0.3 topnode))
+ (newsticker--parse-atom-0.3 feed-name time topnode))
;; Atom 1.0
- ((and (eq 'feed (xml-node-name topnode))
- (string= "http://www.w3.org/2005/Atom"
- (xml-get-attribute topnode 'xmlns)))
- (setq imageurl (newsticker--get-logo-url-atom-1.0 topnode))
- (newsticker--parse-atom-1.0 name time topnode))
- ;; unknown feed type
(t
- (newsticker--debug-msg "Feed type unknown: %s: %s"
- (xml-node-name topnode) name)
- nil))
+ ;; The test for Atom 1.0 does not work when using
+ ;; libxml, as with libxml the namespace attribute is
+ ;; not in the xml tree. For the time being we skip
+ ;; the check and assume that we are dealing with an
+ ;; Atom 1.0 feed.
+
+ ;; (and (eq 'feed (xml-node-name topnode))
+ ;; (string= "http://www.w3.org/2005/Atom"
+ ;; (xml-get-attribute topnode 'xmlns)))
+ (setq image-url (newsticker--get-logo-url-atom-1.0 topnode))
+ (setq icon-url (newsticker--get-icon-url-atom-1.0 topnode))
+ (newsticker--parse-atom-1.0 feed-name time topnode))
+ ;; unknown feed type
+ ;; (t
+ ;; (newsticker--debug-msg "Feed type unknown: %s: %s"
+ ;; (xml-node-name topnode) feed-name)
+ ;; nil)
+ )
(setq something-was-added t))
- (error (message "sentinelerror in %s: %s" name error-data)))
+ (error (message "sentinelerror in %s: %s" feed-name error-data)))
;; Remove those old items from cache which have been removed from
;; the feed
@@ -1038,17 +999,97 @@ Argument BUFFER is the buffer of the retrieval process."
;; kill the process buffer if wanted
(unless newsticker-debug
(kill-buffer buffer))
- ;; launch retrieval of image
- (when (and imageurl newsticker--download-logos)
- (newsticker--image-get name imageurl)))))
+ ;; launch retrieval of images
+ (when (and (boundp 'newsticker-download-logos)
+ newsticker-download-logos)
+ ;; feed logo
+ (when image-url
+ (newsticker--image-get feed-name feed-name (newsticker--images-dir)
+ image-url))
+ ;; icon / favicon
+ (setq icon-url
+ (or icon-url
+ (let* ((feed-url (newsticker--link (cadr (newsticker--cache-get-feed
+ (intern feed-name)))))
+ (uri (url-generic-parse-url feed-url)))
+ (when (and feed-url uri)
+ (setf (url-filename uri) nil)
+ (setf (url-target uri) nil)
+ (concat (url-recreate-url uri) "favicon.ico")))))
+ (when icon-url
+ (newsticker--image-get feed-name
+ (concat feed-name "."
+ (file-name-extension icon-url))
+ (newsticker--icons-dir)
+ icon-url))))))
(when newsticker--sentinel-callback
(funcall newsticker--sentinel-callback)))
+(defun newsticker--do-xml-workarounds ()
+ "Fix all issues which `xml-parse-region' could be choking on."
+
+ ;; a very very dirty workaround to overcome the
+ ;; problems with the newest (20030621) xml.el:
+ ;; remove all unnecessary whitespace
+ (goto-char (point-min))
+ (while (re-search-forward ">[ \t\r\n]+<" nil t)
+ (replace-match "><" nil t))
+ ;; and another brutal workaround (20031105)! For some
+ ;; reason the xml parser does not like the colon in the
+ ;; doctype name "rdf:RDF"
+ (goto-char (point-min))
+ (if (re-search-forward "<!DOCTYPE[ \t\n]+rdf:RDF" nil t)
+ (replace-match "<!DOCTYPE rdfColonRDF" nil t))
+ ;; finally.... ~##^°!!!!!
+ (goto-char (point-min))
+ (while (search-forward "\r\n" nil t)
+ (replace-match "\n" nil t))
+ ;; still more brutal workarounds (20040309)! The xml
+ ;; parser does not like doctype rss
+ (goto-char (point-min))
+ (if (re-search-forward "<!DOCTYPE[ \t\n]+rss[ \t\n]*>" nil t)
+ (replace-match "" nil t))
+ ;; And another one (20050618)! (Fixed in GNU Emacs 22.0.50.18)
+ ;; Remove comments to avoid this xml-parsing bug:
+ ;; "XML files can have only one toplevel tag"
+ (goto-char (point-min))
+ (while (search-forward "<!--" nil t)
+ (let ((start (match-beginning 0)))
+ (unless (search-forward "-->" nil t)
+ (error "Can't find end of comment"))
+ (delete-region start (point))))
+ ;; And another one (20050702)! If description is HTML
+ ;; encoded and starts with a `<', wrap the whole
+ ;; description in a CDATA expression. This happened for
+ ;; http://www.thefreedictionary.com/_/WoD/rss.aspx?type=quote
+ (goto-char (point-min))
+ (while (re-search-forward
+ "<description>\\(<img.*?\\)</description>" nil t)
+ (replace-match
+ "<description><![CDATA[ \\1 ]]></description>"))
+ ;; And another one (20051123)! XML parser does not
+ ;; like this: <yweather:location city="Frankfurt/Main"
+ ;; region="" country="GM" />
+ ;; try to "fix" empty attributes
+ ;; This happened for
+ ;; http://xml.weather.yahoo.com/forecastrss?p=GMXX0040&u=f
+ (goto-char (point-min))
+ (while (re-search-forward "\\(<[^>]*\\)=\"\"" nil t)
+ (replace-match "\\1=\" \""))
+ ;;
+ (set-buffer-modified-p nil))
+
+
(defun newsticker--get-logo-url-atom-1.0 (node)
"Return logo URL from atom 1.0 data in NODE."
(car (xml-node-children
(car (xml-get-children node 'logo)))))
+(defun newsticker--get-icon-url-atom-1.0 (node)
+ "Return icon URL from atom 1.0 data in NODE."
+ (car (xml-node-children
+ (car (xml-get-children node 'icon)))))
+
(defun newsticker--get-logo-url-atom-0.3 (node)
"Return logo URL from atom 0.3 data in NODE."
(car (xml-node-children
@@ -1125,6 +1166,30 @@ same as in `newsticker--parse-atom-1.0'."
(xml-node-children node))))
(or new-item new-feed)))
+(defun newsticker--unxml (node)
+ "Reverse parsing of an xml string.
+Restore an xml-string from a an xml NODE that was returned by xml-parse..."
+ (if (or (not node) (stringp node))
+ node
+ (newsticker--unxml-node node)))
+
+(defun newsticker--unxml-node (node)
+ "Actually restore xml-string of an xml NODE."
+ (let ((qname (symbol-name (car node)))
+ (att-list (cadr node))
+ (children (cddr node)))
+ (concat "<" qname
+ (when att-list " ")
+ (mapconcat 'newsticker--unxml-attribute att-list " ")
+ ">"
+ (mapconcat 'newsticker--unxml children "") "</" qname ">")))
+
+(defun newsticker--unxml-attribute (attribute)
+ "Actually restore xml-string of an ATTRIBUTE of an xml node."
+ (let ((name (symbol-name (car attribute)))
+ (value (cdr attribute)))
+ (concat name "=\"" value "\"")))
+
(defun newsticker--parse-atom-1.0 (name time topnode)
"Parse Atom 1.0 data.
Argument NAME gives the name of a news feed. TIME gives the
@@ -1157,8 +1222,17 @@ URL `http://www.atompub.org/2005/08/17/draft-ietf-atompub-format-11.html'"
(car (xml-get-children node 'title)))))
;; desc-fn
(lambda (node)
- (or (car (xml-node-children
- (car (xml-get-children node 'content))))
+ ;; unxml the content or the summary node. Atom
+ ;; allows for integrating (x)html into the atom
+ ;; structure but we need the raw html string.
+ ;; e.g. http://www.heise.de/open/news/news-atom.xml
+ ;; http://feeds.feedburner.com/ru_nix_blogs
+ (or (newsticker--unxml
+ (car (xml-node-children
+ (car (xml-get-children node 'content)))))
+ (newsticker--unxml
+ (car (xml-node-children
+ (car (xml-get-children node 'summary)))))
(car (xml-node-children
(car (xml-get-children node 'summary))))))
;; link-fn
@@ -1303,9 +1377,15 @@ For the RSS 1.0 specification see URL `http://web.resource.org/rss/1.0/spec'."
(car (xml-node-children
(car (xml-get-children channelnode 'title))))
;; desc
- (car (xml-node-children
- (car (xml-get-children channelnode
- 'description))))
+ (or (car (xml-node-children
+ (car (xml-get-children channelnode
+ 'encoded))))
+ (car (xml-node-children
+ (car (xml-get-children channelnode
+ 'content:encoded))))
+ (car (xml-node-children
+ (car (xml-get-children channelnode
+ 'description)))))
;; link
(car (xml-node-children
(car (xml-get-children channelnode 'link))))
@@ -1329,8 +1409,10 @@ For the RSS 1.0 specification see URL `http://web.resource.org/rss/1.0/spec'."
;; time-fn
(lambda (node)
(newsticker--decode-iso8601-date
- (car (xml-node-children
- (car (xml-get-children node 'dc:date))))))
+ (or (car (xml-node-children
+ (car (xml-get-children node 'dc:date))))
+ (car (xml-node-children
+ (car (xml-get-children node 'date)))))))
;; guid-fn
(lambda (node)
nil)
@@ -1354,9 +1436,15 @@ For the RSS 2.0 specification see URL `http://blogs.law.harvard.edu/tech/rss'."
(car (xml-node-children
(car (xml-get-children channelnode 'title))))
;; desc
- (car (xml-node-children
- (car (xml-get-children channelnode
- 'description))))
+ (or (car (xml-node-children
+ (car (xml-get-children channelnode
+ 'encoded))))
+ (car (xml-node-children
+ (car (xml-get-children channelnode
+ 'content:encoded))))
+ (car (xml-node-children
+ (car (xml-get-children channelnode
+ 'description)))))
;; link
(car (xml-node-children
(car (xml-get-children channelnode 'link))))
@@ -1372,6 +1460,9 @@ For the RSS 2.0 specification see URL `http://blogs.law.harvard.edu/tech/rss'."
(lambda (node)
(or (car (xml-node-children
(car (xml-get-children node
+ 'encoded))))
+ (car (xml-node-children
+ (car (xml-get-children node
'content:encoded))))
(car (xml-node-children
(car (xml-get-children node
@@ -1464,7 +1555,7 @@ argument, which is one of the items in ITEMLIST."
;; decode numeric entities
(setq title (xml-substitute-numeric-entities title))
(when desc
- (setq desc (xml-substitute-numeric-entities desc)))
+ (setq desc (xml-substitute-numeric-entities desc)))
(setq link (xml-substitute-numeric-entities link))
;; remove whitespace from title, desc, and link
(setq title (newsticker--remove-whitespace title))
@@ -1486,9 +1577,9 @@ argument, which is one of the items in ITEMLIST."
(let ((prev-age (newsticker--age old-item)))
(unless newsticker-automatically-mark-items-as-old
;; Some feeds deliver items multiply, the
- ;; first time we find an 'obsolete-old one the
- ;; cache, the following times we find an 'old
- ;; one
+ ;; first time we find an 'obsolete-old one in
+ ;; the cache, the following times we find an
+ ;; 'old one
(if (memq prev-age '(obsolete-old old))
(setq age2 'old)
(setq age2 'new)))
@@ -1498,11 +1589,16 @@ argument, which is one of the items in ITEMLIST."
;; item was not there
(setq item-new-p t)
(setq something-was-added t))
- (setq newsticker--cache
- (newsticker--cache-add
- newsticker--cache (intern name) title desc link
- time age1 position (funcall extra-fn node)
- time age2))
+ (let ((extra-elements-with-guid (funcall extra-fn node)))
+ (unless (assoc 'guid extra-elements-with-guid)
+ (setq extra-elements-with-guid
+ (cons `(guid nil ,(funcall guid-fn node))
+ extra-elements-with-guid)))
+ (setq newsticker--cache
+ (newsticker--cache-add
+ newsticker--cache (intern name) title desc link
+ time age1 position extra-elements-with-guid
+ time age2)))
(when item-new-p
(let ((item (newsticker--cache-contains
newsticker--cache (intern name) title
@@ -1712,31 +1808,44 @@ Checks list of active processes against list of newsticker processes."
;; ======================================================================
(defun newsticker--images-dir ()
"Return directory where feed images are saved."
- (concat newsticker-dir "/images"))
+ (concat newsticker-dir "/images/"))
-(defun newsticker--image-get (feed-name url)
- "Get image of the news site FEED-NAME from URL.
-If the image has been downloaded in the last 24h do nothing."
- (let ((image-name (concat (newsticker--images-dir) feed-name)))
+(defun newsticker--icons-dir ()
+ "Return directory where feed icons are saved."
+ (concat newsticker-dir "/icons/"))
+
+(defun newsticker--image-get (feed-name filename directory url)
+ "Get image for FEED-NAME by returning FILENAME from DIRECTORY.
+If the file does no exist or if it is older than 24 hours
+download it from URL first."
+ (let ((image-name (concat directory feed-name)))
(if (and (file-exists-p image-name)
(time-less-p (current-time)
(time-add (nth 5 (file-attributes image-name))
(seconds-to-time 86400))))
(newsticker--debug-msg "%s: Getting image for %s skipped"
- (format-time-string "%A, %H:%M" (current-time))
+ (format-time-string "%A, %H:%M")
feed-name)
;; download
(newsticker--debug-msg "%s: Getting image for %s"
- (format-time-string "%A, %H:%M" (current-time))
+ (format-time-string "%A, %H:%M")
feed-name)
- (let* ((buffername (concat " *newsticker-wget-image-" feed-name "*"))
- (item (or (assoc feed-name newsticker-url-list)
+ (if (eq newsticker-retrieval-method 'intern)
+ (newsticker--image-download-by-url feed-name filename directory url)
+ (newsticker--image-download-by-wget feed-name filename directory url)))))
+
+(defun newsticker--image-download-by-wget (feed-name filename directory url)
+ "Download image for FEED-NAME using external program.
+Save image as FILENAME in DIRECTORY, download it from URL."
+ (let* ((proc-name (concat feed-name "-" filename))
+ (buffername (concat " *newsticker-wget-image-" proc-name "*"))
+ (item (or (assoc feed-name newsticker-url-list)
(assoc feed-name newsticker-url-list-defaults)
(error
- "Cannot get news for %s: Check newsticker-url-list"
+ "Cannot get image for %s: Check newsticker-url-list"
feed-name)))
- (wget-arguments (or (car (cdr (cdr (cdr (cdr item)))))
- newsticker-wget-arguments)))
+ (wget-arguments (or (car (cdr (cdr (cdr (cdr item)))))
+ newsticker-wget-arguments)))
(with-current-buffer (get-buffer-create buffername)
(erase-buffer)
;; throw an error if there is an old wget-process around
@@ -1745,39 +1854,96 @@ If the image has been downloaded in the last 24h do nothing."
feed-name))
;; start wget
(let* ((args (append wget-arguments (list url)))
- (proc (apply 'start-process feed-name buffername
+ (proc (apply 'start-process proc-name buffername
newsticker-wget-name args)))
(set-process-coding-system proc 'no-conversion 'no-conversion)
- (set-process-sentinel proc 'newsticker--image-sentinel)))))))
+ (set-process-sentinel proc 'newsticker--image-sentinel)
+ (process-put proc 'nt-directory directory)
+ (process-put proc 'nt-feed-name feed-name)
+ (process-put proc 'nt-filename filename)))))
(defun newsticker--image-sentinel (process event)
"Sentinel for image-retrieving PROCESS caused by EVENT."
(let* ((p-status (process-status process))
(exit-status (process-exit-status process))
- (feed-name (process-name process)))
+ (feed-name (process-get process 'nt-feed-name))
+ (directory (process-get process 'nt-directory))
+ (filename (process-get process 'nt-filename)))
;; catch known errors (zombie processes, rubbish-xml, etc.)
;; if an error occurs the news feed is not updated!
(catch 'oops
(unless (and (eq p-status 'exit)
(= exit-status 0))
(message "%s: Error while retrieving image from %s"
- (format-time-string "%A, %H:%M" (current-time))
+ (format-time-string "%A, %H:%M")
feed-name)
+ (newsticker--image-remove directory feed-name)
(throw 'oops nil))
- (let (image-name)
- (with-current-buffer (process-buffer process)
- (setq image-name (concat (newsticker--images-dir) feed-name))
- (set-buffer-file-coding-system 'no-conversion)
- ;; make sure the cache dir exists
- (unless (file-directory-p (newsticker--images-dir))
- (make-directory (newsticker--images-dir)))
- ;; write and close buffer
- (let ((require-final-newline nil)
- (backup-inhibited t)
- (coding-system-for-write 'no-conversion))
- (write-region nil nil image-name nil 'quiet))
- (set-buffer-modified-p nil)
- (kill-buffer (current-buffer)))))))
+ (newsticker--image-save (process-buffer process) directory filename))))
+
+(defun newsticker--image-save (buffer directory file-name)
+ "Save contents of BUFFER in DIRECTORY as FILE-NAME.
+Finally kill buffer."
+ (with-current-buffer buffer
+ (let ((image-name (concat directory file-name)))
+ (set-buffer-file-coding-system 'no-conversion)
+ ;; make sure the cache dir exists
+ (unless (file-directory-p directory)
+ (make-directory directory))
+ ;; write and close buffer
+ (let ((require-final-newline nil)
+ (backup-inhibited t)
+ (coding-system-for-write 'no-conversion))
+ (write-region nil nil image-name nil 'quiet))
+ (set-buffer-modified-p nil)
+ (kill-buffer buffer))))
+
+(defun newsticker--image-remove (directory file-name)
+ "In DIRECTORY remove FILE-NAME."
+ (let ((image-name (concat directory file-name)))
+ (when (file-exists-p file-name)
+ (delete-file image-name))))
+
+(defun newsticker--image-download-by-url (feed-name filename directory url)
+ "Download image for FEED-NAME using `url-retrieve'.
+Save image as FILENAME in DIRECTORY, download it from URL."
+ (let ((coding-system-for-read 'no-conversion))
+ (condition-case error-data
+ (url-retrieve url 'newsticker--image-download-by-url-callback
+ (list feed-name directory filename))
+ (error (message "Error retrieving image from %s: %s" feed-name
+ error-data))))
+ (force-mode-line-update))
+
+(defun newsticker--image-download-by-url-callback (status feed-name directory filename)
+ "Callback function for `newsticker--image-download-by-url'.
+STATUS is the return status as delivered by `url-retrieve'.
+FEED-NAME is the name of the feed that the news were retrieved
+from.
+The image is saved in DIRECTORY as FILENAME."
+ (let ((do-save
+ (or (not status)
+ (let ((status-type (car status))
+ (status-details (cdr status)))
+ (cond ((eq status-type :redirect)
+ ;; don't care about redirects
+ t)
+ ((eq status-type :error)
+ ;; silently ignore errors
+ nil))))))
+ (when do-save
+ (let ((buf (get-buffer-create (concat " *newsticker-url-image-" feed-name "-"
+ directory "*")))
+ (result (string-to-multibyte (buffer-string))))
+ (set-buffer buf)
+ (erase-buffer)
+ (insert result)
+ ;; remove MIME header
+ (goto-char (point-min))
+ (search-forward "\n\n")
+ (delete-region (point-min) (point))
+ ;; save
+ (newsticker--image-save buf directory filename)))))
(defun newsticker--insert-image (img string)
"Insert IMG with STRING at point."
@@ -2192,6 +2358,7 @@ If AGE is nil, the total number of items is returned."
(defun newsticker-opml-export ()
"OPML subscription export.
Export subscriptions to a buffer in OPML Format."
+ ;; FIXME: use newsticker-groups
(interactive)
(with-current-buffer (get-buffer-create "*OPML Export*")
(set-buffer-file-coding-system 'utf-8)
@@ -2211,7 +2378,8 @@ Export subscriptions to a buffer in OPML Format."
(insert " <outline text=\"")
(insert (newsticker--title sub))
(insert "\" xmlUrl=\"")
- (insert (cadr sub))
+ (insert (xml-escape-string (let ((url (cadr sub)))
+ (if (stringp url) url (prin1-to-string url)))))
(insert "\"/>\n"))
(append newsticker-url-list newsticker-url-list-defaults))
(insert " </body>\n</opml>\n"))
diff --git a/lisp/net/newst-plainview.el b/lisp/net/newst-plainview.el
index 9b9044b4efe..4ab000750ee 100644
--- a/lisp/net/newst-plainview.el
+++ b/lisp/net/newst-plainview.el
@@ -5,7 +5,6 @@
;; Author: Ulf Jasper <ulf.jasper@web.de>
;; Filename: newst-plainview.el
;; URL: http://www.nongnu.org/newsticker
-;; Time-stamp: "Mon 11-Feb-2013 20:27:11 gm on skiddaw"
;; Package: newsticker
;; ======================================================================
diff --git a/lisp/net/newst-reader.el b/lisp/net/newst-reader.el
index 3e336e12801..be4179e4b11 100644
--- a/lisp/net/newst-reader.el
+++ b/lisp/net/newst-reader.el
@@ -5,7 +5,6 @@
;; Author: Ulf Jasper <ulf.jasper@web.de>
;; Filename: newst-reader.el
;; URL: http://www.nongnu.org/newsticker
-;; Time-stamp: "24. September 2011, 15:47:49 (ulf)"
;; Package: newsticker
;; ======================================================================
@@ -67,6 +66,12 @@ This must be one of the functions `newsticker-plainview' or
:group 'newsticker-reader)
;; image related things
+(defcustom newsticker-download-logos
+ t
+ "If non-nil newsticker downloads logo images of subscribed feeds."
+ :type 'boolean
+ :group 'newsticker-reader)
+
(defcustom newsticker-enable-logo-manipulations
t
"If non-nil newsticker manipulates logo images.
@@ -105,7 +110,7 @@ window is used when filling. See also `newsticker-justification'."
#'shr-render-region)
"Function for rendering HTML contents.
If non-nil, newsticker.el will call this function whenever it
-finds HTML-like tags in item descriptions.
+finds HTML-like tags in item descriptions.
Possible functions include `shr-render-region', `w3m-region', `w3-region', and
`newsticker-htmlr-render'.
Newsticker automatically loads the respective package w3m, w3, or
@@ -186,15 +191,18 @@ KEYMAP will be applied."
'nt-type 'desc))
(insert "\n")))))
-(defun newsticker--print-extra-elements (item keymap)
+(defun newsticker--print-extra-elements (item keymap &optional htmlish)
"Insert extra-elements of ITEM in a pretty form into the current buffer.
-KEYMAP is applied."
+KEYMAP is applied. If HTMLISH is non-nil then HTML-markup is used
+for formatting."
(let ((ignored-elements '(items link title description content
- content:encoded dc:subject
- dc:date entry item guid pubDate
+ content:encoded encoded
+ dc:subject subject
+ dc:date date entry item guid pubDate
published updated
enclosure))
(left-column-width 1))
+ (if htmlish (insert "<ul>"))
(mapc (lambda (extra-element)
(when (listp extra-element) ;; take care of broken xml
;; data, 2007-05-25
@@ -209,15 +217,20 @@ KEYMAP is applied."
(unless (memq (car extra-element) ignored-elements)
(newsticker--do-print-extra-element extra-element
left-column-width
- keymap))))
- (newsticker--extra item))))
+ keymap
+ htmlish))))
+ (newsticker--extra item))
+ (if htmlish (insert "</ul>"))))
-(defun newsticker--do-print-extra-element (extra-element width keymap)
+(defun newsticker--do-print-extra-element (extra-element width keymap htmlish)
"Actually print an EXTRA-ELEMENT using the given WIDTH.
-KEYMAP is applied."
+KEYMAP is applied. If HTMLISH is non-nil then HTML-markup is used
+for formatting."
(let ((name (symbol-name (car extra-element))))
- (insert (format "%s: " name))
- (insert (make-string (- width (length name)) ? )))
+ (if htmlish
+ (insert (format "<li>%s: " name))
+ (insert (format "%s: " name))
+ (insert (make-string (- width (length name)) ? ))))
(let (;;(attributes (cadr extra-element)) ;FIXME!!!!
(contents (cddr extra-element)))
(cond ((listp contents)
@@ -238,30 +251,58 @@ KEYMAP is applied."
contents))
(t
(insert (format "%s" contents))))
- (insert "\n")))
+ (if htmlish
+ (insert "</li>")
+ (insert "\n"))))
-(defun newsticker--image-read (feed-name-symbol disabled)
+(defun newsticker--image-read (feed-name-symbol disabled &optional max-height)
"Read the cached image for FEED-NAME-SYMBOL from disk.
If DISABLED is non-nil the image will be converted to a disabled look
\(unless `newsticker-enable-logo-manipulations' is not t\).
+Optional argument MAX-HEIGHT specifies the maximal image height.
Return the image."
(let ((image-name (concat (newsticker--images-dir)
- (symbol-name feed-name-symbol)))
- (img nil))
+ (symbol-name feed-name-symbol))))
(when (file-exists-p image-name)
(condition-case error-data
- (setq img (create-image
- image-name nil nil
- :conversion (and newsticker-enable-logo-manipulations
- disabled
- 'disabled)
- :mask (and newsticker-enable-logo-manipulations
- 'heuristic)
- :ascent 70))
+ (create-image
+ image-name
+ (and (fboundp 'imagemagick-types)
+ (imagemagick-types)
+ 'imagemagick)
+ nil
+ :conversion (and newsticker-enable-logo-manipulations
+ disabled
+ 'disabled)
+ :mask (and newsticker-enable-logo-manipulations
+ 'heuristic)
+ :ascent 100
+ :max-height max-height)
(error
(message "Error: cannot create image for %s: %s"
- feed-name-symbol error-data))))
- img))
+ feed-name-symbol error-data))))))
+
+(defun newsticker--icon-read (feed-name-symbol)
+ "Read the cached icon for FEED-NAME-SYMBOL from disk.
+Return the image."
+ (catch 'icon
+ (when (file-exists-p (newsticker--icons-dir))
+ (dolist (file (directory-files (newsticker--icons-dir) t
+ (concat (symbol-name feed-name-symbol) "\\..*")))
+ (condition-case error-data
+ (throw 'icon (create-image
+ file (and (fboundp 'imagemagick-types)
+ (imagemagick-types)
+ 'imagemagick)
+ nil
+ :ascent 'center
+ :max-width 16
+ :max-height 16))
+ (error
+ (message "Error: cannot create icon for %s: %s"
+ feed-name-symbol error-data)))))
+ ;; Fallback: default icon.
+ (find-image '((:type png :file "newsticker/rss-feed.png" :ascent center)))))
;; the functions we need for retrieval and display
;;;###autoload
diff --git a/lisp/net/newst-ticker.el b/lisp/net/newst-ticker.el
index 5035287c580..9426bb7a8e4 100644
--- a/lisp/net/newst-ticker.el
+++ b/lisp/net/newst-ticker.el
@@ -6,7 +6,6 @@
;; Filename: newst-ticker.el
;; URL: http://www.nongnu.org/newsticker
;; Keywords: News, RSS, Atom
-;; Time-stamp: "6. Dezember 2009, 19:16:00 (ulf)"
;; Package: newsticker
;; ======================================================================
@@ -37,6 +36,14 @@
(require 'newst-backend)
+(defvar newsticker--item-list nil
+ "List of newsticker items.")
+(defvar newsticker--item-position 0
+ "Actual position in list of newsticker items.")
+(defvar newsticker--prev-message "There was no previous message yet!"
+ "Last message that the newsticker displayed.")
+(defvar newsticker--scrollable-text ""
+ "The text which is scrolled smoothly in the echo area.")
(defvar newsticker--ticker-timer nil
"Timer for newsticker ticker.")
diff --git a/lisp/net/newst-treeview.el b/lisp/net/newst-treeview.el
index bd2b96c9e1b..a9647501b48 100644
--- a/lisp/net/newst-treeview.el
+++ b/lisp/net/newst-treeview.el
@@ -83,6 +83,14 @@
"Face for newsticker selection."
:group 'newsticker-treeview)
+(defcustom newsticker-treeview-date-format
+ "%d.%m.%y, %H:%M"
+ "Format for the date column in the treeview list buffer.
+See `format-time-string' for a list of valid specifiers."
+ :version "25.1"
+ :type 'string
+ :group 'newsticker-treeview)
+
(defcustom newsticker-treeview-own-frame
nil
"Decides whether newsticker treeview creates and uses its own frame."
@@ -124,8 +132,9 @@ Example: (\"Topmost group\" \"feed1\" (\"subgroup1\" \"feed 2\")
\"feed3\")")
(defcustom newsticker-groups-filename
- "~/.newsticker-groups"
- "Name of the newsticker groups settings file."
+ nil
+ "Name of the newsticker groups settings file. This variable is obsolete."
+ :version "25.1" ; changed default value to nil
:type 'string
:group 'newsticker-treeview)
(make-obsolete-variable 'newsticker-groups-filename 'newsticker-dir "23.1")
@@ -230,23 +239,23 @@ their id stays constant."
(newsticker--treeview-do-get-node-of-feed feed-name
newsticker--treeview-vfeed-tree)))
-(defun newsticker--treeview-do-get-node (id startnode)
+(defun newsticker--treeview-do-get-node-by-id (id startnode)
"Recursively search node with ID starting from STARTNODE."
(if (newsticker--treeview-ids-eq id (widget-get startnode :nt-id))
(throw 'found startnode)
(let ((children (widget-get startnode :children)))
(dolist (w children)
- (newsticker--treeview-do-get-node id w)))))
+ (newsticker--treeview-do-get-node-by-id id w)))))
-(defun newsticker--treeview-get-node (id)
+(defun newsticker--treeview-get-node-by-id (id)
"Return node with ID in newsticker treeview tree."
(catch 'found
- (newsticker--treeview-do-get-node id newsticker--treeview-feed-tree)
- (newsticker--treeview-do-get-node id newsticker--treeview-vfeed-tree)))
+ (newsticker--treeview-do-get-node-by-id id newsticker--treeview-feed-tree)
+ (newsticker--treeview-do-get-node-by-id id newsticker--treeview-vfeed-tree)))
(defun newsticker--treeview-get-current-node ()
"Return current node in newsticker treeview tree."
- (newsticker--treeview-get-node newsticker--treeview-current-node-id))
+ (newsticker--treeview-get-node-by-id newsticker--treeview-current-node-id))
;; ======================================================================
@@ -307,7 +316,7 @@ If string SHOW-FEED is non-nil it is shown in the item string."
0 10)
(propertize " " 'display '(space :align-to 12)))
""))
- (insert (format-time-string "%d.%m.%y, %H:%M"
+ (insert (format-time-string newsticker-treeview-date-format
(newsticker--time item)))
(insert (propertize " " 'display
(list 'space :align-to (if show-feed 28 18))))
@@ -319,7 +328,8 @@ If string SHOW-FEED is non-nil it is shown in the item string."
(while (search-forward "\n" nil t)
(replace-match " "))
(let ((map (make-sparse-keymap)))
- (define-key map [mouse-1] 'newsticker-treeview-tree-click)
+ (dolist (key'([mouse-1] [mouse-3]))
+ (define-key map key 'newsticker-treeview-tree-click))
(define-key map "\n" 'newsticker-treeview-show-item)
(define-key map "\C-m" 'newsticker-treeview-show-item)
(add-text-properties pos1 (point-max)
@@ -708,7 +718,9 @@ for the button."
(remove-overlays)
(when (and item feed-name-symbol)
- (let ((wwidth (1- (window-width (newsticker--treeview-item-window)))))
+ (let ((wwidth (1- (if (window-live-p (newsticker--treeview-item-window))
+ (window-width (newsticker--treeview-item-window))
+ fill-column))))
(if newsticker-use-full-width
(set (make-local-variable 'fill-column) wwidth))
(set (make-local-variable 'fill-column) (min fill-column
@@ -727,7 +739,7 @@ for the button."
(goto-char (point-min))
;; insert logo at top
(let* ((newsticker-enable-logo-manipulations nil)
- (img (newsticker--image-read feed-name-symbol nil)))
+ (img (newsticker--image-read feed-name-symbol nil 40)))
(if (and (display-images-p) img)
(newsticker--insert-image img (car item))
(insert (newsticker--real-feed-name feed-name-symbol))))
@@ -773,8 +785,11 @@ for the button."
(put-text-property pos (point) 'face 'newsticker-enclosure-face)
(setq pos (point))
(insert "\n")
- (newsticker--print-extra-elements item newsticker--treeview-url-keymap)
- (put-text-property pos (point) 'face 'newsticker-extra-face)
+ (set-marker marker1 pos)
+ (newsticker--print-extra-elements item newsticker--treeview-url-keymap t)
+ (set-marker marker2 (point))
+ (newsticker--treeview-render-text marker1 marker2)
+ (put-text-property marker1 marker2 'face 'newsticker-extra-face)
(goto-char (point-min)))))
(if (and newsticker-treeview-automatically-mark-displayed-items-as-old
item
@@ -818,6 +833,7 @@ Callback function for tree widget that adds nodes for feeds and subgroups."
:nt-group ,(cdr g)
:nt-feed ,g-name
:nt-id ,nt-id
+ :leaf-icon newsticker--tree-widget-leaf-icon
:keep (:nt-feed :num-new :nt-id :open);; :nt-group
:open nil))
(let ((tag (newsticker--treeview-tree-get-tag g nil nt-id)))
@@ -830,6 +846,23 @@ Callback function for tree widget that adds nodes for feeds and subgroups."
:open t))))
group)))
+(defun newsticker--tree-widget-icon-create (icon)
+ "Create the ICON widget."
+ (let* ((g (widget-get (widget-get icon :node) :nt-feed))
+ (ico (and g (newsticker--icon-read (intern g)))))
+ (if ico
+ (progn
+ (widget-put icon :tag-glyph ico)
+ (widget-default-create icon)
+ ;; Insert space between the icon and the node widget.
+ (insert-char ? 1)
+ (put-text-property
+ (1- (point)) (point)
+ 'display (list 'space :width tree-widget-space-width)))
+ ;; fallback: default icon
+ (widget-put icon :leaf-icon 'tree-widget-leaf-icon)
+ (tree-widget-icon-create icon))))
+
(defun newsticker--treeview-tree-expand-status (tree &optional changed-widget
event)
"Expand the vfeed TREE.
@@ -864,6 +897,7 @@ Optional arguments CHANGED-WIDGET and EVENT are ignored."
"Icon for a tree-widget leaf node."
:tag "O"
:glyph-name "leaf"
+ :create 'newsticker--tree-widget-icon-create
:button-face 'default)
(defun newsticker--treeview-tree-update ()
@@ -912,7 +946,8 @@ arguments NT-ID, FEED, and VFEED are added as properties."
(map (make-sparse-keymap)))
(if (and num-new (> num-new 0))
(setq face 'newsticker-treeview-new-face))
- (define-key map [mouse-1] 'newsticker-treeview-tree-click)
+ (dolist (key '([mouse-1] [mouse-3]))
+ (define-key map key 'newsticker-treeview-tree-click))
(define-key map "\n" 'newsticker-treeview-tree-do-click)
(define-key map "\C-m" 'newsticker-treeview-tree-do-click)
(propertize tag 'face face 'keymap map
@@ -1158,12 +1193,14 @@ Arguments IGNORE are ignored."
(unless newsticker--selection-overlay
(with-current-buffer (newsticker--treeview-list-buffer)
+ (setq buffer-undo-list t)
(setq newsticker--selection-overlay (make-overlay (point-min)
(point-max)))
(overlay-put newsticker--selection-overlay 'face
'newsticker-treeview-selection-face)))
(unless newsticker--tree-selection-overlay
(with-current-buffer (newsticker--treeview-tree-buffer)
+ (setq buffer-undo-list t)
(setq newsticker--tree-selection-overlay (make-overlay (point-min)
(point-max)))
(overlay-put newsticker--tree-selection-overlay 'face
@@ -1210,7 +1247,7 @@ Note: does not update the layout."
(newsticker-treeview-save))
(defun newsticker-treeview-save ()
- "Save newsticker data including treeview settings."
+ "Save treeview group settings."
(interactive)
(let ((coding-system-for-write 'utf-8)
(buf (find-file-noselect (concat newsticker-dir "/groups"))))
@@ -1227,16 +1264,27 @@ Note: does not update the layout."
"Load treeview settings."
(let* ((coding-system-for-read 'utf-8)
(filename
- (or (and (file-exists-p newsticker-groups-filename)
+ (or (and newsticker-groups-filename
+ (not (string=
+ (expand-file-name newsticker-groups-filename)
+ (expand-file-name (concat newsticker-dir "/groups"))))
+ (file-exists-p newsticker-groups-filename)
(y-or-n-p
- (format "Old newsticker groups (%s) file exists. Read it? "
- newsticker-groups-filename))
+ (format
+ (concat "Obsolete variable `newsticker-groups-filename' "
+ "points to existing file \"%s\".\n"
+ "Read it? ")
+ newsticker-groups-filename))
newsticker-groups-filename)
(concat newsticker-dir "/groups")))
(buf (and (file-exists-p filename)
(find-file-noselect filename))))
- (and (file-exists-p newsticker-groups-filename)
- (y-or-n-p (format "Delete old newsticker groups file? "))
+ (and newsticker-groups-filename
+ (file-exists-p newsticker-groups-filename)
+ (y-or-n-p (format
+ (concat "Delete the file \"%s\",\nto which the obsolete "
+ "variable `newsticker-groups-filename' points ? ")
+ newsticker-groups-filename))
(delete-file newsticker-groups-filename))
(when buf
(set-buffer buf)
@@ -1590,10 +1638,8 @@ Return t if a new feed was activated, nil otherwise."
"Recursively show subtree above the node that represents FEED-NAME."
(let ((node (newsticker--treeview-get-node-of-feed feed-name)))
(unless node
- (let* ((group-name (or (car (newsticker--group-find-group-for-feed
- feed-name))
- (newsticker--group-get-parent-group
- feed-name))))
+ (let* ((group-name (car (newsticker--group-find-parent-group
+ feed-name))))
(newsticker--treeview-unfold-node group-name))
(setq node (newsticker--treeview-get-node-of-feed feed-name)))
(when node
@@ -1617,20 +1663,31 @@ Return t if a new feed was activated, nil otherwise."
;; ======================================================================
;;; Groups
;; ======================================================================
-(defun newsticker--group-do-find-group-for-feed (feed-name node)
- "Recursively find FEED-NAME in NODE."
- (if (member feed-name (cdr node))
- (throw 'found node)
- (mapc (lambda (n)
- (if (listp n)
- (newsticker--group-do-find-group-for-feed feed-name n)))
- (cdr node))))
-
-(defun newsticker--group-find-group-for-feed (feed-name)
- "Find group containing FEED-NAME."
+(defun newsticker--group-do-find-group (feed-or-group-name parent-node node)
+ "Recursively find FEED-OR-GROUP-NAME in PARENT-NODE or NODE."
+ (cond ((stringp node)
+ (when (string= feed-or-group-name node)
+ (throw 'found parent-node)))
+ ((listp node)
+ (cond ((string= feed-or-group-name (car node))
+ (throw 'found parent-node))
+ ((member feed-or-group-name (cdr node))
+ (throw 'found node))
+ (t
+ (mapc (lambda (n)
+ (if (listp n)
+ (newsticker--group-do-find-group
+ feed-or-group-name node n)))
+ (cdr node)))))))
+
+(defun newsticker--group-find-parent-group (feed-or-group-name)
+ "Find group containing FEED-OR-GROUP-NAME."
(catch 'found
- (newsticker--group-do-find-group-for-feed feed-name
- newsticker-groups)
+ (mapc (lambda (n)
+ (newsticker--group-do-find-group feed-or-group-name
+ newsticker-groups
+ n))
+ newsticker-groups)
nil))
(defun newsticker--group-do-get-group (name node)
@@ -1651,26 +1708,6 @@ Return t if a new feed was activated, nil otherwise."
newsticker-groups)
nil))
-(defun newsticker--group-do-get-parent-group (name node parent)
- "Recursively find parent group for NAME from NODE which is a child of PARENT."
- (if (string= name (car node))
- (throw 'found parent)
- (mapc (lambda (n)
- (if (listp n)
- (newsticker--group-do-get-parent-group name n (car node))))
- (cdr node))))
-
-(defun newsticker--group-get-parent-group (name)
- "Find parent group for group named NAME."
- (catch 'found
- (mapc (lambda (n)
- (if (listp n)
- (newsticker--group-do-get-parent-group
- name n (car newsticker-groups))))
- newsticker-groups)
- nil))
-
-
(defun newsticker--group-get-subgroups (group &optional recursive)
"Return list of subgroups for GROUP.
If RECURSIVE is non-nil recursively get subgroups and return a nested list."
@@ -1706,9 +1743,9 @@ return a nested list."
(defun newsticker-group-add-group (name parent)
"Add group NAME to group PARENT."
(interactive
- (list (read-string "Group Name: ")
+ (list (read-string "Name of new group: ")
(let ((completion-ignore-case t))
- (completing-read "Parent Group: " (newsticker--group-all-groups)
+ (completing-read "Name of parent group (optional): " (newsticker--group-all-groups)
nil t))))
(if (newsticker--group-get-group name)
(error "Group %s exists already" name))
@@ -1718,46 +1755,154 @@ return a nested list."
(unless p
(error "Parent %s does not exist" parent))
(setcdr p (cons (list name) (cdr p))))
- (newsticker--treeview-tree-update))
+ (newsticker--treeview-tree-update)
+ (newsticker-treeview-jump newsticker--treeview-current-feed))
+
+(defun newsticker-group-delete-group (name)
+ "Delete group NAME."
+ (interactive
+ (list (let ((completion-ignore-case t))
+ (completing-read "Delete group: "
+ (newsticker--group-names)
+ nil t (car (newsticker--group-find-parent-group
+ newsticker--treeview-current-feed))))))
+ (let ((parent-group (newsticker--group-find-parent-group name)))
+ (unless parent-group
+ (error "Parent %s does not exist" parent-group))
+ (setcdr parent-group (cl-delete-if (lambda (g)
+ (and (listp g)
+ (string= name (car g))))
+ (cdr parent-group)))
+ (newsticker--group-manage-orphan-feeds)
+ (newsticker--treeview-tree-update)
+ (newsticker-treeview-update)
+ (newsticker-treeview-jump newsticker--treeview-current-feed)))
+
+(defun newsticker--group-do-rename-group (old-name new-name)
+ "Actually rename group OLD-NAME to NEW-NAME."
+ (let ((parent-group (newsticker--group-find-parent-group old-name)))
+ (unless parent-group
+ (error "Parent of %s does not exist" old-name))
+ (mapcar (lambda (elt)
+ (cond ((and (listp elt)
+ (string= old-name (car elt)))
+ (cons new-name (cdr elt)))
+ (t
+ elt))) parent-group)))
+
+(defun newsticker-group-rename-group (old-name new-name)
+ "Rename group OLD-NAME to NEW-NAME."
+ (interactive
+ (list (let* ((completion-ignore-case t))
+ (completing-read "Rename group: "
+ (newsticker--group-names)
+ nil t (car (newsticker--group-find-parent-group
+ newsticker--treeview-current-feed))))
+ (read-string "Rename to: ")))
+ (setq newsticker-groups (newsticker--group-do-rename-group old-name new-name))
+ (newsticker--group-manage-orphan-feeds)
+ (newsticker--treeview-tree-update)
+ (newsticker-treeview-update)
+ (newsticker-treeview-jump newsticker--treeview-current-feed))
+
+(defun newsticker--get-group-names (lst)
+ "Do get the group names from LST."
+ (delete nil (cons (car lst)
+ (apply 'append
+ (mapcar (lambda (e)
+ (cond ((listp e)
+ (newsticker--get-group-names e))
+ (t
+ nil)))
+ (cdr lst))))))
+
+(defun newsticker--group-names ()
+ "Get names of all newsticker groups."
+ (newsticker--get-group-names newsticker-groups))
(defun newsticker-group-move-feed (name group-name &optional no-update)
"Move feed NAME to group GROUP-NAME.
Update treeview afterwards unless NO-UPDATE is non-nil."
(interactive
(let ((completion-ignore-case t))
- (list (completing-read "Feed Name: "
- (mapcar 'car newsticker-url-list)
+ (list (completing-read "Name of feed or group to move: "
+ (append (mapcar 'car newsticker-url-list)
+ (newsticker--group-names))
nil t newsticker--treeview-current-feed)
- (completing-read "Group Name: " (newsticker--group-all-groups)
+ (completing-read "Name of new parent group: " (newsticker--group-names)
nil t))))
- (let ((group (if (and group-name (not (string= group-name "")))
- (newsticker--group-get-group group-name)
- newsticker-groups)))
+ (let* ((group (if (and group-name (not (string= group-name "")))
+ (newsticker--group-get-group group-name)
+ newsticker-groups))
+ (moving-group-p (member name (newsticker--group-names)))
+ (moved-thing (if moving-group-p
+ (newsticker--group-get-group name)
+ name)))
(unless group
(error "Group %s does not exist" group-name))
(while (let ((old-group
- (newsticker--group-find-group-for-feed name)))
+ (newsticker--group-find-parent-group name)))
(when old-group
- (delete name old-group))
+ (delete moved-thing old-group))
old-group))
- (setcdr group (cons name (cdr group)))
+ (setcdr group (cons moved-thing (cdr group)))
(unless no-update
(newsticker--treeview-tree-update)
- (newsticker-treeview-update))))
+ (newsticker-treeview-update)
+ (newsticker-treeview-jump name))))
-(defun newsticker-group-delete-group (name)
- "Remove group NAME."
- (interactive
- (let ((completion-ignore-case t))
- (list (completing-read "Group Name: " (newsticker--group-all-groups)
- nil t))))
- (let* ((g (newsticker--group-get-group name))
- (p (or (newsticker--group-get-parent-group name)
- newsticker-groups)))
- (unless g
- (error "Group %s does not exist" name))
- (delete g p))
- (newsticker--treeview-tree-update))
+(defun newsticker-group-shift-feed-down ()
+ "Shift current feed down in its group."
+ (interactive)
+ (newsticker--group-shift 1))
+
+(defun newsticker-group-shift-feed-up ()
+ "Shift current feed down in its group."
+ (interactive)
+ (newsticker--group-shift -1))
+
+(defun newsticker-group-shift-group-down ()
+ "Shift current group down in its group."
+ (interactive)
+ (newsticker--group-shift 1 t))
+
+(defun newsticker-group-shift-group-up ()
+ "Shift current group down in its group."
+ (interactive)
+ (newsticker--group-shift -1 t))
+
+(defun newsticker--group-shift (delta &optional move-group)
+ "Shift current feed or group within its parent group.
+DELTA is an integer which specifies the direction and the amount
+of the shift. If MOVE-GROUP is nil the currently selected feed
+`newsticker--treeview-current-feed' is shifted, if it is t then
+the current feed's parent group is shifted.."
+ (let* ((cur-feed newsticker--treeview-current-feed)
+ (thing (if move-group
+ (newsticker--group-find-parent-group cur-feed)
+ cur-feed))
+ (parent-group (newsticker--group-find-parent-group
+ (if move-group (car thing) thing))))
+ (unless parent-group
+ (error "Group not found!"))
+ (let* ((siblings (cdr parent-group))
+ (pos (cl-position thing siblings :test 'equal))
+ (tpos (+ pos delta ))
+ (new-pos (max 0 (min (length siblings) tpos)))
+ (beg (cl-subseq siblings 0 (min pos new-pos)))
+ (end (cl-subseq siblings (+ 1 (max pos new-pos))))
+ (p (elt siblings new-pos)))
+ (when (not (= pos new-pos))
+ (setcdr parent-group
+ (cl-concatenate 'list
+ beg
+ (if (> delta 0)
+ (list p thing)
+ (list thing p))
+ end))
+ (newsticker--treeview-tree-update)
+ (newsticker-treeview-update)
+ (newsticker-treeview-jump cur-feed)))))
(defun newsticker--count-groups (group)
"Recursively count number of subgroups of GROUP."
@@ -1804,7 +1949,7 @@ Return t if groups have changed, nil otherwise."
(let ((new-feed nil)
(grouped-feeds (newsticker--count-grouped-feeds newsticker-groups)))
(mapc (lambda (f)
- (unless (newsticker--group-find-group-for-feed (car f))
+ (unless (newsticker--group-find-parent-group (car f))
(setq new-feed t)
(newsticker-group-move-feed (car f) nil t)))
(append newsticker-url-list-defaults newsticker-url-list))
@@ -1817,37 +1962,22 @@ Return t if groups have changed, nil otherwise."
;; ======================================================================
;;; Modes
;; ======================================================================
-(defun newsticker--treeview-create-groups-menu (group-list
- excluded-group)
- "Create menu for GROUP-LIST omitting EXCLUDED-GROUP."
- (let ((menu (make-sparse-keymap (if (stringp (car group-list))
- (car group-list)
- "Move to group..."))))
- (mapc (lambda (g)
- (when (listp g)
- (let ((title (if (stringp (car g))
- (car g)
- "Move to group...")))
- (unless (eq g excluded-group)
- (define-key menu (vector (intern title))
- (list 'menu-item title
- (newsticker--treeview-create-groups-menu
- (cdr g) excluded-group)))))))
- (reverse group-list))
- menu))
-
-(defun newsticker--treeview-create-tree-menu (feed-name)
- "Create tree menu for FEED-NAME."
- (let ((menu (make-sparse-keymap feed-name)))
+(defun newsticker--treeview-tree-open-menu (event)
+ "Open tree menu at position of EVENT."
+ (let* ((feed-name newsticker--treeview-current-feed)
+ (menu (make-sparse-keymap feed-name)))
(define-key menu [newsticker-treeview-mark-list-items-old]
(list 'menu-item "Mark all items old"
'newsticker-treeview-mark-list-items-old))
- (define-key menu [move]
- (list 'menu-item "Move to group..."
- (newsticker--treeview-create-groups-menu
- newsticker-groups
- (newsticker--group-get-group feed-name))))
- menu))
+ (define-key menu [newsticker-treeview-get-news]
+ (list 'menu-item (concat "Get news for " feed-name)
+ 'newsticker-treeview-get-news))
+ (define-key menu [newsticker-get-all-news]
+ (list 'menu-item "Get news for all feeds"
+ 'newsticker-get-all-news))
+ (let ((choice (x-popup-menu event menu)))
+ (when choice
+ (funcall (car choice))))))
(defvar newsticker-treeview-list-menu
(let ((menu (make-sparse-keymap "Newsticker List")))
@@ -1906,6 +2036,12 @@ Return t if groups have changed, nil otherwise."
;;(define-key map "\C-m" 'newsticker-treeview-scroll-item)
(define-key map "\M-m" 'newsticker-group-move-feed)
(define-key map "\M-a" 'newsticker-group-add-group)
+ (define-key map "\M-d" 'newsticker-group-delete-group)
+ (define-key map "\M-r" 'newsticker-group-rename-group)
+ (define-key map [M-down] 'newsticker-group-shift-feed-down)
+ (define-key map [M-up] 'newsticker-group-shift-feed-up)
+ (define-key map [M-S-down] 'newsticker-group-shift-group-down)
+ (define-key map [M-S-up] 'newsticker-group-shift-group-up)
map)
"Mode map for newsticker treeview.")
@@ -1950,7 +2086,7 @@ Return t if groups have changed, nil otherwise."
(newsticker--treeview-restore-layout)
(save-excursion
(switch-to-buffer (window-buffer (posn-window (event-end event))))
- (newsticker-treeview-tree-do-click (posn-point (event-end event)))))
+ (newsticker-treeview-tree-do-click (posn-point (event-end event)) event)))
(defun newsticker-treeview-tree-do-click (&optional pos event)
"Actually handle click event.
@@ -1964,13 +2100,17 @@ POS gives the position where EVENT occurred."
(newsticker-treeview-show-item))
(t
;; click in tree buffer
- (let ((w (newsticker--treeview-get-node nt-id)))
+ (let ((w (newsticker--treeview-get-node-by-id nt-id)))
(when w
(newsticker--treeview-tree-update-tag w t t)
- (setq w (newsticker--treeview-get-node nt-id))
+ (setq w (newsticker--treeview-get-node-by-id nt-id))
(widget-put w :nt-selected t)
(widget-apply w :action event)
- (newsticker--treeview-set-current-node w))))))
+ (newsticker--treeview-set-current-node w)
+ (and event
+ (eq 'mouse-3 (car event))
+ (sit-for 0)
+ (newsticker--treeview-tree-open-menu event)))))))
(newsticker--treeview-tree-update-highlight))
(defun newsticker--treeview-restore-layout ()
diff --git a/lisp/net/newsticker.el b/lisp/net/newsticker.el
index 730b7f8fc65..9b16c1f0749 100644
--- a/lisp/net/newsticker.el
+++ b/lisp/net/newsticker.el
@@ -7,8 +7,6 @@
;; URL: http://www.nongnu.org/newsticker
;; Created: 17. June 2003
;; Keywords: News, RSS, Atom
-;; Time-stamp: "6. Dezember 2009, 19:15:18 (ulf)"
-;; Version: 1.99
;; ======================================================================
@@ -28,6 +26,7 @@
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
(defconst newsticker-version "1.99" "Version number of newsticker.el.")
+(make-obsolete-variable 'newsticker-version 'emacs-version "25.1")
;; ======================================================================
;;; Commentary:
diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el
new file mode 100644
index 00000000000..2312e22d96a
--- /dev/null
+++ b/lisp/net/nsm.el
@@ -0,0 +1,502 @@
+;;; nsm.el --- Network Security Manager
+
+;; Copyright (C) 2014-2015 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
+;; Keywords: encryption, security, network
+
+;; 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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'cl-lib)
+
+(defvar nsm-permanent-host-settings nil)
+(defvar nsm-temporary-host-settings nil)
+
+(defgroup nsm nil
+ "Network Security Manager"
+ :version "25.1"
+ :group 'comm)
+
+(defcustom network-security-level 'medium
+ "How secure the network should be.
+If a potential problem with the security of the network
+connection is found, the user is asked to give input into how the
+connection should be handled.
+
+The following values are possible:
+
+`low': Absolutely no checks are performed.
+`medium': This is the default level, should be reasonable for most usage.
+`high': This warns about additional things that many people would
+not find useful.
+`paranoid': On this level, the user is queried for most new connections.
+
+See the Emacs manual for a description of all things that are
+checked and warned against."
+ :version "25.1"
+ :group 'nsm
+ :type '(choice (const :tag "Low" low)
+ (const :tag "Medium" medium)
+ (const :tag "High" high)
+ (const :tag "Paranoid" paranoid)))
+
+(defcustom nsm-settings-file (expand-file-name "network-security.data"
+ user-emacs-directory)
+ "The file the security manager settings will be stored in."
+ :version "25.1"
+ :group 'nsm
+ :type 'file)
+
+(defcustom nsm-save-host-names nil
+ "If non-nil, always save host names in the structures in `nsm-settings-file'.
+By default, only hosts that have exceptions have their names
+stored in plain text."
+ :version "25.1"
+ :group 'nsm
+ :type 'boolean)
+
+(defvar nsm-noninteractive nil
+ "If non-nil, the connection is opened in a non-interactive context.
+This means that no queries should be performed.")
+
+(defun nsm-verify-connection (process host port &optional
+ save-fingerprint warn-unencrypted)
+ "Verify the security status of PROCESS that's connected to HOST:PORT.
+If PROCESS is a gnutls connection, the certificate validity will
+be examined. If it's a non-TLS connection, it may be compared
+against previous connections. If the function determines that
+there is something odd about the connection, the user will be
+queried about what to do about it.
+
+The process it returned if everything is OK, and otherwise, the
+process will be deleted and nil is returned.
+
+If SAVE-FINGERPRINT, always save the fingerprint of the
+server (if the connection is a TLS connection). This is useful
+to keep track of the TLS status of STARTTLS servers.
+
+If WARN-UNENCRYPTED, query the user if the connection is
+unencrypted."
+ (if (eq network-security-level 'low)
+ process
+ (let* ((status (gnutls-peer-status process))
+ (id (nsm-id host port))
+ (settings (nsm-host-settings id)))
+ (cond
+ ((not (process-live-p process))
+ nil)
+ ((not status)
+ ;; This is a non-TLS connection.
+ (nsm-check-plain-connection process host port settings
+ warn-unencrypted))
+ (t
+ (let ((process
+ (nsm-check-tls-connection process host port status settings)))
+ (when (and process save-fingerprint
+ (null (nsm-host-settings id)))
+ (nsm-save-host host port status 'fingerprint 'always))
+ process))))))
+
+(defun nsm-check-tls-connection (process host port status settings)
+ (let ((process (nsm-check-certificate process host port status settings)))
+ (if (and process
+ (>= (nsm-level network-security-level) (nsm-level 'high)))
+ ;; Do further protocol-level checks if the security is high.
+ (nsm-check-protocol process host port status settings)
+ process)))
+
+(defun nsm-check-certificate (process host port status settings)
+ (let ((warnings (plist-get status :warnings)))
+ (cond
+
+ ;; The certificate validated, but perhaps we want to do
+ ;; certificate pinning.
+ ((null warnings)
+ (cond
+ ((< (nsm-level network-security-level) (nsm-level 'high))
+ process)
+ ;; The certificate is fine, but if we're paranoid, we might
+ ;; want to check whether it's changed anyway.
+ ((and (>= (nsm-level network-security-level) (nsm-level 'high))
+ (not (nsm-fingerprint-ok-p host port status settings)))
+ (delete-process process)
+ nil)
+ ;; We haven't seen this before, and we're paranoid.
+ ((and (eq network-security-level 'paranoid)
+ (null settings)
+ (not (nsm-new-fingerprint-ok-p host port status)))
+ (delete-process process)
+ nil)
+ ((>= (nsm-level network-security-level) (nsm-level 'high))
+ ;; Save the host fingerprint so that we can check it the
+ ;; next time we connect.
+ (nsm-save-host host port status 'fingerprint 'always)
+ process)
+ (t
+ process)))
+
+ ;; The certificate did not validate.
+ ((not (equal network-security-level 'low))
+ ;; We always want to pin the certificate of invalid connections
+ ;; to track man-in-the-middle or the like.
+ (if (not (nsm-fingerprint-ok-p host port status settings))
+ (progn
+ (delete-process process)
+ nil)
+ ;; We have a warning, so query the user.
+ (if (and (not (nsm-warnings-ok-p status settings))
+ (not (nsm-query
+ host port status 'conditions
+ "The TLS connection to %s:%s is insecure for the following reason%s:\n\n%s"
+ host port
+ (if (> (length warnings) 1)
+ "s" "")
+ (mapconcat #'gnutls-peer-status-warning-describe
+ warnings
+ "\n"))))
+ (progn
+ (delete-process process)
+ nil)
+ process))))))
+
+(defun nsm-check-protocol (process host port status settings)
+ (let ((prime-bits (plist-get status :diffie-hellman-prime-bits))
+ (encryption (format "%s-%s-%s"
+ (plist-get status :key-exchange)
+ (plist-get status :cipher)
+ (plist-get status :mac)))
+ (protocol (plist-get status :protocol)))
+ (cond
+ ((and prime-bits
+ (< prime-bits 1024)
+ (not (memq :diffie-hellman-prime-bits
+ (plist-get settings :conditions)))
+ (not
+ (nsm-query
+ host port status :diffie-hellman-prime-bits
+ "The Diffie-Hellman prime bits (%s) used for this connection to %s:%s is less than what is considered safe (%s)."
+ prime-bits host port 1024)))
+ (delete-process process)
+ nil)
+ ((and (string-match "\\bRC4\\b" encryption)
+ (not (memq :rc4 (plist-get settings :conditions)))
+ (not
+ (nsm-query
+ host port status :rc4
+ "The connection to %s:%s uses the RC4 algorithm (%s), which is believed to be unsafe."
+ host port encryption)))
+ (delete-process process)
+ nil)
+ ((and protocol
+ (string-match "SSL" protocol)
+ (not (memq :ssl (plist-get settings :conditions)))
+ (not
+ (nsm-query
+ host port status :ssl
+ "The connection to %s:%s uses the %s protocol, which is believed to be unsafe."
+ host port protocol)))
+ (delete-process process)
+ nil)
+ (t
+ process))))
+
+(defun nsm-fingerprint (status)
+ (plist-get (plist-get status :certificate) :public-key-id))
+
+(defun nsm-fingerprint-ok-p (host port status settings)
+ (let ((did-query nil))
+ (if (and settings
+ (not (eq (plist-get settings :fingerprint) :none))
+ (not (equal (nsm-fingerprint status)
+ (plist-get settings :fingerprint)))
+ (not
+ (setq did-query
+ (nsm-query
+ host port status 'fingerprint
+ "The fingerprint for the connection to %s:%s has changed from %s to %s"
+ host port
+ (plist-get settings :fingerprint)
+ (nsm-fingerprint status)))))
+ ;; Not OK.
+ nil
+ (when did-query
+ ;; Remove any exceptions that have been set on the previous
+ ;; certificate.
+ (plist-put settings :conditions nil))
+ t)))
+
+(defun nsm-new-fingerprint-ok-p (host port status)
+ (nsm-query
+ host port status 'fingerprint
+ "The fingerprint for the connection to %s:%s is new: %s"
+ host port
+ (nsm-fingerprint status)))
+
+(defun nsm-check-plain-connection (process host port settings warn-unencrypted)
+ ;; If this connection used to be TLS, but is now plain, then it's
+ ;; possible that we're being Man-In-The-Middled by a proxy that's
+ ;; stripping out STARTTLS announcements.
+ (cond
+ ((and (plist-get settings :fingerprint)
+ (not (eq (plist-get settings :fingerprint) :none))
+ (not
+ (nsm-query
+ host port nil 'conditions
+ "The connection to %s:%s used to be an encrypted connection, but is now unencrypted. This might mean that there's a man-in-the-middle tapping this connection."
+ host port)))
+ (delete-process process)
+ nil)
+ ((and warn-unencrypted
+ (not (memq :unencrypted (plist-get settings :conditions)))
+ (not (nsm-query
+ host port nil 'conditions
+ "The connection to %s:%s is unencrypted."
+ host port)))
+ (delete-process process)
+ nil)
+ (t
+ process)))
+
+(defun nsm-query (host port status what message &rest args)
+ ;; If there is no user to answer queries, then say `no' to everything.
+ (if (or noninteractive
+ nsm-noninteractive)
+ nil
+ (let ((response
+ (condition-case nil
+ (nsm-query-user message args (nsm-format-certificate status))
+ ;; Make sure we manage to close the process if the user hits
+ ;; `C-g'.
+ (quit 'no)
+ (error 'no))))
+ (if (eq response 'no)
+ nil
+ (nsm-save-host host port status what response)
+ t))))
+
+(defun nsm-query-user (message args cert)
+ (let ((buffer (get-buffer-create "*Network Security Manager*")))
+ (with-help-window buffer
+ (with-current-buffer buffer
+ (erase-buffer)
+ (when (> (length cert) 0)
+ (insert cert "\n"))
+ (let ((start (point)))
+ (insert (apply 'format message args))
+ (goto-char start)
+ ;; Fill the first line of the message, which usually
+ ;; contains lots of explanatory text.
+ (fill-region (point) (line-end-position)))))
+ (let ((responses '((?n . no)
+ (?s . session)
+ (?a . always)))
+ (prefix "")
+ response)
+ (while (not response)
+ (setq response
+ (cdr
+ (assq (downcase
+ (read-char
+ (concat prefix
+ "Continue connecting? (No, Session only, Always)")))
+ responses)))
+ (unless response
+ (ding)
+ (setq prefix "Invalid choice. ")))
+ (kill-buffer buffer)
+ ;; If called from a callback, `read-char' will insert things
+ ;; into the pending input. Clear that.
+ (clear-this-command-keys)
+ response)))
+
+(defun nsm-save-host (host port status what permanency)
+ (let* ((id (nsm-id host port))
+ (saved
+ (list :id id
+ :fingerprint (or (nsm-fingerprint status)
+ ;; Plain connection.
+ :none))))
+ (when (or (eq what 'conditions)
+ nsm-save-host-names)
+ (nconc saved (list :host (format "%s:%s" host port))))
+ ;; We either want to save/update the fingerprint or the conditions
+ ;; of the certificate/unencrypted connection.
+ (cond
+ ((eq what 'conditions)
+ (cond
+ ((not status)
+ (nconc saved '(:conditions (:unencrypted))))
+ ((plist-get status :warnings)
+ (nconc saved
+ (list :conditions (plist-get status :warnings))))))
+ ((not (eq what 'fingerprint))
+ ;; Store additional protocol settings.
+ (let ((settings (nsm-host-settings id)))
+ (when settings
+ (setq saved settings))
+ (if (plist-get saved :conditions)
+ (nconc (plist-get saved :conditions) (list what))
+ (nconc saved (list :conditions (list what)))))))
+ (if (eq permanency 'always)
+ (progn
+ (nsm-remove-temporary-setting id)
+ (nsm-remove-permanent-setting id)
+ (push saved nsm-permanent-host-settings)
+ (nsm-write-settings))
+ (nsm-remove-temporary-setting id)
+ (push saved nsm-temporary-host-settings))))
+
+(defun nsm-write-settings ()
+ (with-temp-file nsm-settings-file
+ (insert "(\n")
+ (dolist (setting nsm-permanent-host-settings)
+ (insert " ")
+ (prin1 setting (current-buffer))
+ (insert "\n"))
+ (insert ")\n")))
+
+(defun nsm-read-settings ()
+ (setq nsm-permanent-host-settings
+ (with-temp-buffer
+ (insert-file-contents nsm-settings-file)
+ (goto-char (point-min))
+ (ignore-errors (read (current-buffer))))))
+
+(defun nsm-id (host port)
+ (concat "sha1:" (sha1 (format "%s:%s" host port))))
+
+(defun nsm-host-settings (id)
+ (when (and (not nsm-permanent-host-settings)
+ (file-exists-p nsm-settings-file))
+ (nsm-read-settings))
+ (let ((result nil))
+ (dolist (elem (append nsm-temporary-host-settings
+ nsm-permanent-host-settings))
+ (when (and (not result)
+ (equal (plist-get elem :id) id))
+ (setq result elem)))
+ result))
+
+(defun nsm-warnings-ok-p (status settings)
+ (let ((ok t)
+ (conditions (plist-get settings :conditions)))
+ (dolist (warning (plist-get status :warnings))
+ (unless (memq warning conditions)
+ (setq ok nil)))
+ ok))
+
+(defun nsm-remove-permanent-setting (id)
+ (setq nsm-permanent-host-settings
+ (cl-delete-if
+ (lambda (elem)
+ (equal (plist-get elem :id) id))
+ nsm-permanent-host-settings)))
+
+(defun nsm-remove-temporary-setting (id)
+ (setq nsm-temporary-host-settings
+ (cl-delete-if
+ (lambda (elem)
+ (equal (plist-get elem :id) id))
+ nsm-temporary-host-settings)))
+
+(defun nsm-format-certificate (status)
+ (let ((cert (plist-get status :certificate)))
+ (when cert
+ (with-temp-buffer
+ (insert
+ "Certificate information\n"
+ "Issued by:"
+ (nsm-certificate-part (plist-get cert :issuer) "CN" t) "\n"
+ "Issued to:"
+ (or (nsm-certificate-part (plist-get cert :subject) "O")
+ (nsm-certificate-part (plist-get cert :subject) "OU" t))
+ "\n"
+ "Hostname:"
+ (nsm-certificate-part (plist-get cert :subject) "CN" t) "\n")
+ (when (and (plist-get cert :public-key-algorithm)
+ (plist-get cert :signature-algorithm))
+ (insert
+ "Public key:" (plist-get cert :public-key-algorithm)
+ ", signature: " (plist-get cert :signature-algorithm) "\n"))
+ (when (and (plist-get status :key-exchange)
+ (plist-get status :cipher)
+ (plist-get status :mac)
+ (plist-get status :protocol))
+ (insert
+ "Protocol:" (plist-get status :protocol)
+ ", key: " (plist-get status :key-exchange)
+ ", cipher: " (plist-get status :cipher)
+ ", mac: " (plist-get status :mac) "\n"))
+ (when (plist-get cert :certificate-security-level)
+ (insert
+ "Security level:"
+ (propertize (plist-get cert :certificate-security-level)
+ 'face 'bold)
+ "\n"))
+ (insert
+ "Valid:From " (plist-get cert :valid-from)
+ " to " (plist-get cert :valid-to) "\n\n")
+ (goto-char (point-min))
+ (while (re-search-forward "^[^:]+:" nil t)
+ (insert (make-string (- 20 (current-column)) ? )))
+ (buffer-string)))))
+
+(defun nsm-certificate-part (string part &optional full)
+ (let ((part (cadr (assoc part (nsm-parse-subject string)))))
+ (cond
+ (part part)
+ (full string)
+ (t nil))))
+
+(defun nsm-parse-subject (string)
+ (with-temp-buffer
+ (insert string)
+ (goto-char (point-min))
+ (let ((start (point))
+ (result nil))
+ (while (not (eobp))
+ (push (replace-regexp-in-string
+ "[\\]\\(.\\)" "\\1"
+ (buffer-substring start
+ (if (re-search-forward "[^\\]," nil 'move)
+ (1- (point))
+ (point))))
+ result)
+ (setq start (point)))
+ (mapcar
+ (lambda (elem)
+ (let ((pos (cl-position ?= elem)))
+ (if pos
+ (list (substring elem 0 pos)
+ (substring elem (1+ pos)))
+ elem)))
+ (nreverse result)))))
+
+(defun nsm-level (symbol)
+ "Return a numerical level for SYMBOL for easier comparison."
+ (cond
+ ((eq symbol 'low) 0)
+ ((eq symbol 'medium) 1)
+ ((eq symbol 'high) 2)
+ (t 3)))
+
+(provide 'nsm)
+
+;;; nsm.el ends here
diff --git a/lisp/net/ntlm.el b/lisp/net/ntlm.el
index 9b231a09b91..5f02e2977ef 100644
--- a/lisp/net/ntlm.el
+++ b/lisp/net/ntlm.el
@@ -80,8 +80,8 @@ is not given."
(request-msgType (concat (make-string 1 1) (make-string 3 0)))
;0x01 0x00 0x00 0x00
(request-flags (concat (make-string 1 7) (make-string 1 178)
- (make-string 2 0)))
- ;0x07 0xb2 0x00 0x00
+ (make-string 1 8) (make-string 1 0)))
+ ;0x07 0xb2 0x08 0x00
lu ld off-d off-u)
(when (string-match "@" user)
(unless domain
@@ -144,11 +144,35 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of
(setq domain (substring user (1+ (match-beginning 0))))
(setq user (substring user 0 (match-beginning 0))))
- ;; generate response data
- (setq lmRespData
- (ntlm-smb-owf-encrypt (car password-hashes) challengeData))
- (setq ntRespData
- (ntlm-smb-owf-encrypt (cadr password-hashes) challengeData))
+ ;; check if "negotiate NTLM2 key" flag is set in type 2 message
+ (if (not (zerop (logand (aref flags 2) 8)))
+ (let (randomString
+ sessionHash)
+ ;; generate NTLM2 session response data
+ (setq randomString (string-make-unibyte
+ (concat
+ (make-string 1 (random 256))
+ (make-string 1 (random 256))
+ (make-string 1 (random 256))
+ (make-string 1 (random 256))
+ (make-string 1 (random 256))
+ (make-string 1 (random 256))
+ (make-string 1 (random 256))
+ (make-string 1 (random 256)))))
+ (setq sessionHash (secure-hash 'md5
+ (concat challengeData randomString)
+ nil nil t))
+ (setq sessionHash (substring sessionHash 0 8))
+
+ (setq lmRespData (concat randomString (make-string 16 0)))
+ (setq ntRespData (ntlm-smb-owf-encrypt
+ (cadr password-hashes) sessionHash)))
+ (progn
+ ;; generate response data
+ (setq lmRespData
+ (ntlm-smb-owf-encrypt (car password-hashes) challengeData))
+ (setq ntRespData
+ (ntlm-smb-owf-encrypt (cadr password-hashes) challengeData))))
;; get offsets to fields to pack the response struct in a string
(setq lu (length user))
diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el
index dade37dfd9c..74d03f59f3d 100644
--- a/lisp/net/rcirc.el
+++ b/lisp/net/rcirc.el
@@ -1,10 +1,10 @@
-;;; rcirc.el --- default, simple IRC client.
+;;; rcirc.el --- default, simple IRC client -*- lexical-binding: t; -*-
;; Copyright (C) 2005-2015 Free Software Foundation, Inc.
;; Author: Ryan Yeske <rcyeske@gmail.com>
;; Maintainers: Ryan Yeske <rcyeske@gmail.com>,
-;; Deniz Dogan <deniz@dogan.se>
+;; Leo Liu <sdl.web@gmail.com>
;; Keywords: comm
;; This file is part of GNU Emacs.
@@ -43,9 +43,9 @@
;;; Code:
+(require 'cl-lib)
(require 'ring)
(require 'time-date)
-(eval-when-compile (require 'cl))
(defgroup rcirc nil
"Simple IRC client."
@@ -145,11 +145,13 @@ for connections using SSL/TLS."
(defcustom rcirc-fill-column nil
"Column beyond which automatic line-wrapping should happen.
-If nil, use value of `fill-column'. If 'frame-width, use the
-maximum frame width."
- :type '(choice (const :tag "Value of `fill-column'")
- (const :tag "Full frame width" frame-width)
- (integer :tag "Number of columns"))
+If nil, use value of `fill-column'.
+If a function (e.g., `frame-text-width' or `window-text-width'),
+call it to compute the number of columns."
+ :risky t ; can get funcalled
+ :type '(choice (const :tag "Value of `fill-column'" nil)
+ (integer :tag "Number of columns")
+ (function :tag "Function returning the number of columns"))
:group 'rcirc)
(defcustom rcirc-fill-prefix nil
@@ -489,7 +491,7 @@ If ARG is non-nil, instead prompt for connection parameters."
(when (string= server (process-name p))
(setq connected p)))
(if (not connected)
- (condition-case e
+ (condition-case nil
(rcirc-connect server port nick user-name
full-name channels password encryption)
(quit (message "Quit connecting to %s" server)))
@@ -521,6 +523,7 @@ If ARG is non-nil, instead prompt for connection parameters."
(defvar rcirc-user-authenticated nil)
(defvar rcirc-user-disconnect nil)
(defvar rcirc-connecting nil)
+(defvar rcirc-connection-info nil)
(defvar rcirc-process nil)
;;;###autoload
@@ -549,22 +552,23 @@ If ARG is non-nil, instead prompt for connection parameters."
(set-process-sentinel process 'rcirc-sentinel)
(set-process-filter process 'rcirc-filter)
- (set (make-local-variable 'rcirc-process) process)
- (set (make-local-variable 'rcirc-server) server)
- (set (make-local-variable 'rcirc-server-name) server) ; Update when we get 001 response.
- (set (make-local-variable 'rcirc-buffer-alist) nil)
- (set (make-local-variable 'rcirc-nick-table)
- (make-hash-table :test 'equal))
- (set (make-local-variable 'rcirc-nick) nick)
- (set (make-local-variable 'rcirc-process-output) nil)
- (set (make-local-variable 'rcirc-startup-channels) startup-channels)
- (set (make-local-variable 'rcirc-last-server-message-time)
- (current-time))
-
- (set (make-local-variable 'rcirc-timeout-timer) nil)
- (set (make-local-variable 'rcirc-user-disconnect) nil)
- (set (make-local-variable 'rcirc-user-authenticated) nil)
- (set (make-local-variable 'rcirc-connecting) t)
+ (setq-local rcirc-connection-info
+ (list server port nick user-name full-name startup-channels
+ password encryption))
+ (setq-local rcirc-process process)
+ (setq-local rcirc-server server)
+ (setq-local rcirc-server-name server) ; Update when we get 001 response.
+ (setq-local rcirc-buffer-alist nil)
+ (setq-local rcirc-nick-table (make-hash-table :test 'equal))
+ (setq-local rcirc-nick nick)
+ (setq-local rcirc-process-output nil)
+ (setq-local rcirc-startup-channels startup-channels)
+ (setq-local rcirc-last-server-message-time (current-time))
+
+ (setq-local rcirc-timeout-timer nil)
+ (setq-local rcirc-user-disconnect nil)
+ (setq-local rcirc-user-authenticated nil)
+ (setq-local rcirc-connecting t)
(add-hook 'auto-save-hook 'rcirc-log-write)
@@ -595,10 +599,10 @@ If ARG is non-nil, instead prompt for connection parameters."
`(with-current-buffer rcirc-server-buffer
,@body))
-(defun rcirc-float-time ()
+(defalias 'rcirc-float-time
(if (featurep 'xemacs)
- (time-to-seconds (current-time))
- (float-time)))
+ 'time-to-seconds
+ 'float-time))
(defun rcirc-prompt-for-encryption (server-plist)
"Prompt the user for the encryption method to use.
@@ -629,7 +633,7 @@ last ping."
(cancel-timer rcirc-keepalive-timer))
(setq rcirc-keepalive-timer nil)))
-(defun rcirc-handler-ctcp-KEEPALIVE (process target sender message)
+(defun rcirc-handler-ctcp-KEEPALIVE (process _target _sender message)
(with-rcirc-process-buffer process
(setq header-line-format (format "%f" (- (rcirc-float-time)
(string-to-number message))))))
@@ -656,6 +660,16 @@ is non-nil."
"Hook functions called when the process sentinel is called.
Functions are called with PROCESS and SENTINEL arguments.")
+(defcustom rcirc-reconnect-delay 0
+ "The minimum interval in seconds between reconnect attempts.
+When 0, do not auto-reconnect."
+ :version "25.1"
+ :type 'integer
+ :group 'rcirc)
+
+(defvar rcirc-last-connect-time nil
+ "The last time the buffer was connected.")
+
(defun rcirc-sentinel (process sentinel)
"Called when PROCESS receives SENTINEL."
(let ((sentinel (replace-regexp-in-string "\n" "" sentinel)))
@@ -667,8 +681,17 @@ Functions are called with PROCESS and SENTINEL arguments.")
(format "%s: %s (%S)"
(process-name process)
sentinel
- (process-status process)) (not rcirc-target))
+ (process-status process))
+ (not rcirc-target))
(rcirc-disconnect-buffer)))
+ (when (and (string= sentinel "deleted")
+ (< 0 rcirc-reconnect-delay))
+ (let ((now (current-time)))
+ (when (or (null rcirc-last-connect-time)
+ (< rcirc-reconnect-delay
+ (float-time (time-subtract now rcirc-last-connect-time))))
+ (setq rcirc-last-connect-time now)
+ (rcirc-cmd-reconnect nil))))
(run-hook-with-args 'rcirc-sentinel-functions process sentinel))))
(defun rcirc-disconnect-buffer (&optional buffer)
@@ -752,7 +775,7 @@ Function is called with PROCESS, COMMAND, SENDER, ARGS and LINE.")
(defvar rcirc-responses-no-activity '("305" "306")
"Responses that don't trigger activity in the mode-line indicator.")
-(defun rcirc-handler-generic (process response sender args text)
+(defun rcirc-handler-generic (process response sender args _text)
"Generic server response handler."
(rcirc-print process sender response nil
(mapconcat 'identity (cdr args) " ")
@@ -782,11 +805,11 @@ Function is called with PROCESS, COMMAND, SENDER, ARGS and LINE.")
(defun rcirc-buffer-process (&optional buffer)
"Return the process associated with channel BUFFER.
With no argument or nil as argument, use the current buffer."
- (or (get-buffer-process (if buffer
- (with-current-buffer buffer
- rcirc-server-buffer)
- rcirc-server-buffer))
- rcirc-process))
+ (let ((buffer (or buffer (and (buffer-live-p rcirc-server-buffer)
+ rcirc-server-buffer))))
+ (if buffer
+ (with-current-buffer buffer rcirc-process)
+ rcirc-process)))
(defun rcirc-server-name (process)
"Return PROCESS server name, given by the 001 response."
@@ -928,12 +951,12 @@ IRC command completion is performed only if '/' is the first input char."
(defun set-rcirc-decode-coding-system (coding-system)
"Set the decode coding system used in this channel."
(interactive "zCoding system for incoming messages: ")
- (set (make-local-variable 'rcirc-decode-coding-system) coding-system))
+ (setq-local rcirc-decode-coding-system coding-system))
(defun set-rcirc-encode-coding-system (coding-system)
"Set the encode coding system used in this channel."
(interactive "zCoding system for outgoing messages: ")
- (set (make-local-variable 'rcirc-encode-coding-system) coding-system))
+ (setq-local rcirc-encode-coding-system coding-system))
(defvar rcirc-mode-map
(let ((map (make-sparse-keymap)))
@@ -990,25 +1013,26 @@ This number is independent of the number of lines in the buffer.")
(setq major-mode 'rcirc-mode)
(setq mode-line-process nil)
- (set (make-local-variable 'rcirc-input-ring)
- ;; If rcirc-input-ring is already a ring with desired size do
- ;; not re-initialize.
- (if (and (ring-p rcirc-input-ring)
- (= (ring-size rcirc-input-ring)
- rcirc-input-ring-size))
- rcirc-input-ring
- (make-ring rcirc-input-ring-size)))
- (set (make-local-variable 'rcirc-server-buffer) (process-buffer process))
- (set (make-local-variable 'rcirc-target) target)
- (set (make-local-variable 'rcirc-topic) nil)
- (set (make-local-variable 'rcirc-last-post-time) (current-time))
- (set (make-local-variable 'fill-paragraph-function) 'rcirc-fill-paragraph)
- (set (make-local-variable 'rcirc-recent-quit-alist) nil)
- (set (make-local-variable 'rcirc-current-line) 0)
+ (setq-local rcirc-input-ring
+ ;; If rcirc-input-ring is already a ring with desired
+ ;; size do not re-initialize.
+ (if (and (ring-p rcirc-input-ring)
+ (= (ring-size rcirc-input-ring)
+ rcirc-input-ring-size))
+ rcirc-input-ring
+ (make-ring rcirc-input-ring-size)))
+ (setq-local rcirc-server-buffer (process-buffer process))
+ (setq-local rcirc-target target)
+ (setq-local rcirc-topic nil)
+ (setq-local rcirc-last-post-time (current-time))
+ (setq-local fill-paragraph-function 'rcirc-fill-paragraph)
+ (setq-local rcirc-recent-quit-alist nil)
+ (setq-local rcirc-current-line 0)
+ (setq-local rcirc-last-connect-time (current-time))
(use-hard-newlines t)
- (set (make-local-variable 'rcirc-short-buffer-name) nil)
- (set (make-local-variable 'rcirc-urls) nil)
+ (setq-local rcirc-short-buffer-name nil)
+ (setq-local rcirc-urls nil)
;; setup for omitting responses
(setq buffer-invisibility-spec '())
@@ -1023,18 +1047,18 @@ This number is independent of the number of lines in the buffer.")
(serv (if (consp (car i)) (cdar i) "")))
(when (and (string-match chan (or target ""))
(string-match serv (rcirc-server-name process)))
- (set (make-local-variable 'rcirc-decode-coding-system)
- (if (consp (cdr i)) (cadr i) (cdr i)))
- (set (make-local-variable 'rcirc-encode-coding-system)
- (if (consp (cdr i)) (cddr i) (cdr i))))))
+ (setq-local rcirc-decode-coding-system
+ (if (consp (cdr i)) (cadr i) (cdr i)))
+ (setq-local rcirc-encode-coding-system
+ (if (consp (cdr i)) (cddr i) (cdr i))))))
;; setup the prompt and markers
- (set (make-local-variable 'rcirc-prompt-start-marker) (point-max-marker))
- (set (make-local-variable 'rcirc-prompt-end-marker) (point-max-marker))
+ (setq-local rcirc-prompt-start-marker (point-max-marker))
+ (setq-local rcirc-prompt-end-marker (point-max-marker))
(rcirc-update-prompt)
(goto-char rcirc-prompt-end-marker)
- (set (make-local-variable 'overlay-arrow-position) (make-marker))
+ (setq-local overlay-arrow-position (make-marker))
;; if the user changes the major mode or kills the buffer, there is
;; cleanup work to do
@@ -1222,13 +1246,13 @@ Create the buffer if it doesn't exist."
(ring-insert rcirc-input-ring input)
(setq rcirc-input-ring-index 0))))))
-(defun rcirc-fill-paragraph (&optional arg)
- (interactive "p")
+(defun rcirc-fill-paragraph (&optional justify)
+ (interactive "P")
(when (> (point) rcirc-prompt-end-marker)
(save-restriction
(narrow-to-region rcirc-prompt-end-marker (point-max))
(let ((fill-column rcirc-max-message-length))
- (fill-region (point-min) (point-max))))))
+ (fill-region (point-min) (point-max) justify)))))
(defun rcirc-process-input-line (line)
(if (string-match "^/\\([^ ]+\\) ?\\(.*\\)$" line)
@@ -1393,9 +1417,9 @@ is found by looking up RESPONSE in `rcirc-response-formats'."
(rcirc-add-face start (match-beginning 0) face)
(setq start (match-beginning 0))
(replace-match
- (case (aref (match-string 1) 0)
+ (cl-case (aref (match-string 1) 0)
(?f (setq face
- (case (string-to-char (match-string 3))
+ (cl-case (string-to-char (match-string 3))
(?w 'font-lock-warning-face)
(?p 'rcirc-server-prefix)
(?s 'rcirc-server)
@@ -1431,9 +1455,9 @@ is found by looking up RESPONSE in `rcirc-response-formats'."
(rcirc-add-face start (match-beginning 0) face))
(buffer-substring (point-min) (point-max))))
-(defun rcirc-target-buffer (process sender response target text)
+(defun rcirc-target-buffer (process sender response target _text)
"Return a buffer to print the server response."
- (assert (not (bufferp target)))
+ (cl-assert (not (bufferp target)))
(with-rcirc-process-buffer process
(cond ((not target)
(rcirc-any-buffer process))
@@ -1474,11 +1498,10 @@ Returns nil if the information is not recorded."
(defun rcirc-last-line (process nick target)
"Return the line from the last activity from NICK in TARGET."
- (let* ((chanbuf (rcirc-get-buffer process target))
- (line (or (cdr (assoc-string target
- (gethash nick (with-rcirc-server-buffer
- rcirc-nick-table)) t))
- (rcirc-last-quit-line process nick target))))
+ (let ((line (or (cdr (assoc-string target
+ (gethash nick (with-rcirc-server-buffer
+ rcirc-nick-table)) t))
+ (rcirc-last-quit-line process nick target))))
(if line
line
;;(message "line is nil for %s in %s" nick target)
@@ -1883,7 +1906,9 @@ Uninteresting lines are those whose responses are listed in
(message "Rcirc-Omit mode enabled"))
(remove-from-invisibility-spec '(rcirc-omit . nil))
(message "Rcirc-Omit mode disabled"))
- (recenter (when (> (point) rcirc-prompt-start-marker) -1)))
+ (dolist (window (get-buffer-window-list (current-buffer)))
+ (with-selected-window window
+ (recenter (when (> (point) rcirc-prompt-start-marker) -1)))))
(defun rcirc-switch-to-server-buffer ()
"Switch to the server buffer associated with current channel buffer."
@@ -1956,7 +1981,7 @@ activity. Only run if the buffer is not visible and
(let ((t1 (with-current-buffer b1 rcirc-last-post-time))
(t2 (with-current-buffer b2 rcirc-last-post-time)))
(time-less-p t2 t1)))))
- (pushnew type rcirc-activity-types)
+ (cl-pushnew type rcirc-activity-types)
(unless (and (equal rcirc-activity old-activity)
(member type old-types))
(rcirc-update-activity-string)))))
@@ -1977,13 +2002,13 @@ activity. Only run if the buffer is not visible and
(defun rcirc-split-activity (activity)
"Return a cons cell with ACTIVITY split into (lopri . hipri)."
(let (lopri hipri)
- (dolist (buf rcirc-activity)
+ (dolist (buf activity)
(with-current-buffer buf
(if (and rcirc-low-priority-flag
(not (member 'nick rcirc-activity-types)))
- (add-to-list 'lopri buf t)
- (add-to-list 'hipri buf t))))
- (cons lopri hipri)))
+ (push buf lopri)
+ (push buf hipri))))
+ (cons (nreverse lopri) (nreverse hipri))))
(defvar rcirc-update-activity-string-hook nil
"Hook run whenever the activity string is updated.")
@@ -2015,7 +2040,7 @@ activity. Only run if the buffer is not visible and
(with-current-buffer b
(dolist (type rcirc-activity-types)
(rcirc-add-face 0 (length s)
- (case type
+ (cl-case type
(nick 'rcirc-track-nick)
(keyword 'rcirc-track-keyword))
s)))
@@ -2123,7 +2148,7 @@ activity. Only run if the buffer is not visible and
(when (and (listp x) (listp (cadr x)))
(setcdr x (if (> (length (cdr x)) 1)
(rcirc-make-trees (cdr x))
- (setcdr x (list (cdadr x)))))))
+ (setcdr x (list (cl-cdadr x)))))))
alist)))
;;; /commands these are called with 3 args: PROCESS, TARGET, which is
@@ -2211,6 +2236,19 @@ CHANNELS is a comma- or space-separated string of channel names."
reason
rcirc-id-string))))
+(defun-rcirc-command reconnect (_)
+ "Reconnect to current server."
+ (interactive "i")
+ (with-rcirc-server-buffer
+ (cond
+ (rcirc-connecting (message "Already connecting"))
+ ((process-live-p process) (message "Server process is alive"))
+ (t (let ((conn-info rcirc-connection-info))
+ (setf (nth 5 conn-info)
+ (cl-remove-if-not #'rcirc-channel-p
+ (mapcar #'car rcirc-buffer-alist)))
+ (apply #'rcirc-connect conn-info))))))
+
(defun-rcirc-command nick (nick)
"Change nick to NICK."
(interactive "i")
@@ -2281,7 +2319,7 @@ With a prefix arg, prompt for new topic."
(mapconcat 'identity (cdr arglist) " "))))
(rcirc-send-string process (concat "KICK " target " " argstring))))
-(defun rcirc-cmd-ctcp (args &optional process target)
+(defun rcirc-cmd-ctcp (args &optional process _target)
(if (string-match "^\\([^ ]+\\)\\s-+\\(.+\\)$" args)
(let* ((target (match-string 1 args))
(request (upcase (match-string 2 args)))
@@ -2292,7 +2330,7 @@ With a prefix arg, prompt for new topic."
(rcirc-print process (rcirc-nick process) "ERROR" nil
"usage: /ctcp NICK REQUEST")))
-(defun rcirc-ctcp-sender-PING (process target request)
+(defun rcirc-ctcp-sender-PING (process target _request)
"Send a CTCP PING message to TARGET."
(let ((timestamp (format "%.0f" (rcirc-float-time))))
(rcirc-send-ctcp process target "PING" timestamp)))
@@ -2412,21 +2450,20 @@ If ARG is given, opens the URL in a new browser window."
(lambda (x) (>= point (cdr x)))
rcirc-urls))
(completions (mapcar (lambda (x) (car x)) filtered))
- (initial-input (caar filtered))
- (history (mapcar (lambda (x) (car x)) (cdr filtered))))
- (browse-url (completing-read "rcirc browse-url: "
- completions nil nil initial-input 'history)
+ (defaults (mapcar (lambda (x) (car x)) filtered)))
+ (browse-url (completing-read "Rcirc browse-url: "
+ completions nil nil (car defaults) nil defaults)
arg)))
-(defun rcirc-markup-timestamp (sender response)
+(defun rcirc-markup-timestamp (_sender _response)
(goto-char (point-min))
(insert (rcirc-facify (format-time-string rcirc-time-format)
'rcirc-timestamp)))
-(defun rcirc-markup-attributes (sender response)
+(defun rcirc-markup-attributes (_sender _response)
(while (re-search-forward "\\([\C-b\C-_\C-v]\\).*?\\(\\1\\|\C-o\\)" nil t)
(rcirc-add-face (match-beginning 0) (match-end 0)
- (case (char-after (match-beginning 1))
+ (cl-case (char-after (match-beginning 1))
(?\C-b 'bold)
(?\C-v 'italic)
(?\C-_ 'underline)))
@@ -2440,7 +2477,7 @@ If ARG is given, opens the URL in a new browser window."
(while (re-search-forward "\C-o+" nil t)
(delete-region (match-beginning 0) (match-end 0))))
-(defun rcirc-markup-my-nick (sender response)
+(defun rcirc-markup-my-nick (_sender response)
(with-syntax-table rcirc-nick-syntax-table
(while (re-search-forward (concat "\\b"
(regexp-quote (rcirc-nick
@@ -2454,7 +2491,7 @@ If ARG is given, opens the URL in a new browser window."
'rcirc-nick-in-message-full-line)
(rcirc-record-activity (current-buffer) 'nick)))))
-(defun rcirc-markup-urls (sender response)
+(defun rcirc-markup-urls (_sender _response)
(while (and rcirc-url-regexp ;; nil means disable URL catching
(re-search-forward rcirc-url-regexp nil t))
(let* ((start (match-beginning 0))
@@ -2485,7 +2522,7 @@ If ARG is given, opens the URL in a new browser window."
(rcirc-add-face (match-beginning 0) (match-end 0) 'rcirc-keyword)
(rcirc-record-activity (current-buffer) 'keyword))))))
-(defun rcirc-markup-bright-nicks (sender response)
+(defun rcirc-markup-bright-nicks (_sender response)
(when (and rcirc-bright-nicks
(string= response "NAMES"))
(with-syntax-table rcirc-nick-syntax-table
@@ -2493,16 +2530,15 @@ If ARG is given, opens the URL in a new browser window."
(rcirc-add-face (match-beginning 0) (match-end 0)
'rcirc-bright-nick)))))
-(defun rcirc-markup-fill (sender response)
+(defun rcirc-markup-fill (_sender response)
(when (not (string= response "372")) ; /motd
(let ((fill-prefix
(or rcirc-fill-prefix
(make-string (- (point) (line-beginning-position)) ?\s)))
- (fill-column (- (cond ((eq rcirc-fill-column 'frame-width)
- (1- (frame-width)))
- (rcirc-fill-column
- rcirc-fill-column)
- (t fill-column))
+ (fill-column (- (cond ((null rcirc-fill-column) fill-column)
+ ((functionp rcirc-fill-column)
+ (funcall rcirc-fill-column))
+ (t rcirc-fill-column))
;; make sure ... doesn't cause line wrapping
3)))
(fill-region (point) (point-max) nil t))))
@@ -2574,7 +2610,7 @@ If ARG is given, opens the URL in a new browser window."
sender)))
message t))))
-(defun rcirc-check-auth-status (process sender args text)
+(defun rcirc-check-auth-status (process sender args _text)
"Check if the user just authenticated.
If authenticated, runs `rcirc-authenticated-hook' with PROCESS as
the only argument."
@@ -2602,10 +2638,10 @@ the only argument."
(run-hook-with-args 'rcirc-authenticated-hook process)
(remove-hook 'rcirc-authenticated-hook 'rcirc-join-channels-post-auth t))))))
-(defun rcirc-handler-WALLOPS (process sender args text)
+(defun rcirc-handler-WALLOPS (process sender args _text)
(rcirc-print process sender "WALLOPS" sender (car args) t))
-(defun rcirc-handler-JOIN (process sender args text)
+(defun rcirc-handler-JOIN (process sender args _text)
(let ((channel (car args)))
(with-current-buffer (rcirc-get-buffer-create process channel)
;; when recently rejoining, restore the linestamp
@@ -2626,7 +2662,7 @@ the only argument."
(rcirc-print process sender "JOIN" sender channel))))
;; PART and KICK are handled the same way
-(defun rcirc-handler-PART-or-KICK (process response channel sender nick args)
+(defun rcirc-handler-PART-or-KICK (process _response channel _sender nick _args)
(rcirc-ignore-update-automatic nick)
(if (not (string= nick (rcirc-nick process)))
;; this is someone else leaving
@@ -2643,7 +2679,7 @@ the only argument."
(when buffer
(rcirc-disconnect-buffer buffer)))))
-(defun rcirc-handler-PART (process sender args text)
+(defun rcirc-handler-PART (process sender args _text)
(let* ((channel (car args))
(reason (cadr args))
(message (concat channel " " reason)))
@@ -2654,10 +2690,10 @@ the only argument."
(rcirc-handler-PART-or-KICK process "PART" channel sender sender reason)))
-(defun rcirc-handler-KICK (process sender args text)
+(defun rcirc-handler-KICK (process sender args _text)
(let* ((channel (car args))
(nick (cadr args))
- (reason (caddr args))
+ (reason (cl-caddr args))
(message (concat nick " " channel " " reason)))
(rcirc-print process sender "KICK" channel message t)
;; print in private chat buffer if it exists
@@ -2682,7 +2718,7 @@ the only argument."
(cons (cons nick line)
rcirc-recent-quit-alist))))))))))
-(defun rcirc-handler-QUIT (process sender args text)
+(defun rcirc-handler-QUIT (process sender args _text)
(rcirc-ignore-update-automatic sender)
(mapc (lambda (channel)
;; broadcast quit message each channel
@@ -2692,7 +2728,7 @@ the only argument."
(rcirc-nick-channels process sender))
(rcirc-nick-remove process sender))
-(defun rcirc-handler-NICK (process sender args text)
+(defun rcirc-handler-NICK (process sender args _text)
(let* ((old-nick sender)
(new-nick (car args))
(channels (rcirc-nick-channels process old-nick)))
@@ -2723,25 +2759,25 @@ the only argument."
;; reauthenticate
(when rcirc-auto-authenticate-flag (rcirc-authenticate))))))
-(defun rcirc-handler-PING (process sender args text)
+(defun rcirc-handler-PING (process _sender args _text)
(rcirc-send-string process (concat "PONG :" (car args))))
-(defun rcirc-handler-PONG (process sender args text)
+(defun rcirc-handler-PONG (_process _sender _args _text)
;; do nothing
)
-(defun rcirc-handler-TOPIC (process sender args text)
+(defun rcirc-handler-TOPIC (process sender args _text)
(let ((topic (cadr args)))
(rcirc-print process sender "TOPIC" (car args) topic)
(with-current-buffer (rcirc-get-buffer process (car args))
(setq rcirc-topic topic))))
(defvar rcirc-nick-away-alist nil)
-(defun rcirc-handler-301 (process sender args text)
+(defun rcirc-handler-301 (process _sender args text)
"RPL_AWAY"
(let* ((nick (cadr args))
(rec (assoc-string nick rcirc-nick-away-alist))
- (away-message (caddr args)))
+ (away-message (cl-caddr args)))
(when (or (not rec)
(not (string= (cdr rec) away-message)))
;; away message has changed
@@ -2751,7 +2787,7 @@ the only argument."
(setq rcirc-nick-away-alist (cons (cons nick away-message)
rcirc-nick-away-alist))))))
-(defun rcirc-handler-317 (process sender args text)
+(defun rcirc-handler-317 (process sender args _text)
"RPL_WHOISIDLE"
(let* ((nick (nth 1 args))
(idle-secs (string-to-number (nth 2 args)))
@@ -2765,31 +2801,31 @@ the only argument."
nick idle-string signon-string)))
(rcirc-print process sender "317" nil message t)))
-(defun rcirc-handler-332 (process sender args text)
+(defun rcirc-handler-332 (process _sender args _text)
"RPL_TOPIC"
(let ((buffer (or (rcirc-get-buffer process (cadr args))
(rcirc-get-temp-buffer-create process (cadr args)))))
(with-current-buffer buffer
- (setq rcirc-topic (caddr args)))))
+ (setq rcirc-topic (cl-caddr args)))))
-(defun rcirc-handler-333 (process sender args text)
+(defun rcirc-handler-333 (process sender args _text)
"333 says who set the topic and when.
Not in rfc1459.txt"
(let ((buffer (or (rcirc-get-buffer process (cadr args))
(rcirc-get-temp-buffer-create process (cadr args)))))
(with-current-buffer buffer
- (let ((setter (caddr args))
+ (let ((setter (cl-caddr args))
(time (current-time-string
(seconds-to-time
- (string-to-number (cadddr args))))))
+ (string-to-number (cl-cadddr args))))))
(rcirc-print process sender "TOPIC" (cadr args)
(format "%s (%s on %s)" rcirc-topic setter time))))))
-(defun rcirc-handler-477 (process sender args text)
+(defun rcirc-handler-477 (process sender args _text)
"ERR_NOCHANMODES"
- (rcirc-print process sender "477" (cadr args) (caddr args)))
+ (rcirc-print process sender "477" (cadr args) (cl-caddr args)))
-(defun rcirc-handler-MODE (process sender args text)
+(defun rcirc-handler-MODE (process sender args _text)
(let ((target (car args))
(msg (mapconcat 'identity (cdr args) " ")))
(rcirc-print process sender "MODE"
@@ -2809,7 +2845,7 @@ Not in rfc1459.txt"
(let ((tmpnam (concat " " (downcase channel) "TMP" (process-name process))))
(get-buffer-create tmpnam)))
-(defun rcirc-handler-353 (process sender args text)
+(defun rcirc-handler-353 (process _sender args _text)
"RPL_NAMREPLY"
(let ((channel (nth 2 args))
(names (or (nth 3 args) "")))
@@ -2822,7 +2858,7 @@ Not in rfc1459.txt"
(goto-char (point-max))
(insert (car (last args)) " "))))
-(defun rcirc-handler-366 (process sender args text)
+(defun rcirc-handler-366 (process sender args _text)
"RPL_ENDOFNAMES"
(let* ((channel (cadr args))
(buffer (rcirc-get-temp-buffer-create process channel)))
@@ -2847,14 +2883,14 @@ Passwords are stored in `rcirc-authinfo' (which see)."
(dolist (i rcirc-authinfo)
(let ((process (rcirc-buffer-process))
(server (car i))
- (nick (caddr i))
+ (nick (cl-caddr i))
(method (cadr i))
- (args (cdddr i)))
+ (args (cl-cdddr i)))
(when (and (string-match server rcirc-server))
(if (and (memq method '(nickserv chanserv bitlbee))
(string-match nick rcirc-nick))
;; the following methods rely on the user's nickname.
- (case method
+ (cl-case method
(nickserv
(rcirc-send-privmsg
process
@@ -2878,10 +2914,10 @@ Passwords are stored in `rcirc-authinfo' (which see)."
"Q@CServe.quakenet.org"
(format "AUTH %s %s" nick (car args))))))))))
-(defun rcirc-handler-INVITE (process sender args text)
+(defun rcirc-handler-INVITE (process sender args _text)
(rcirc-print process sender "INVITE" nil (mapconcat 'identity args " ") t))
-(defun rcirc-handler-ERROR (process sender args text)
+(defun rcirc-handler-ERROR (process sender args _text)
(rcirc-print process sender "ERROR" nil (mapconcat 'identity args " ")))
(defun rcirc-handler-CTCP (process target sender text)
@@ -2899,7 +2935,7 @@ Passwords are stored in `rcirc-authinfo' (which see)."
(rcirc-print process sender "CTCP" target
(format "%s" text) t))))))
-(defun rcirc-handler-ctcp-VERSION (process target sender args)
+(defun rcirc-handler-ctcp-VERSION (process _target sender _args)
(rcirc-send-string process
(concat "NOTICE " sender
" :\C-aVERSION " rcirc-id-string
@@ -2908,12 +2944,12 @@ Passwords are stored in `rcirc-authinfo' (which see)."
(defun rcirc-handler-ctcp-ACTION (process target sender args)
(rcirc-print process sender "ACTION" target args t))
-(defun rcirc-handler-ctcp-TIME (process target sender args)
+(defun rcirc-handler-ctcp-TIME (process _target sender _args)
(rcirc-send-string process
(concat "NOTICE " sender
" :\C-aTIME " (current-time-string) "\C-a")))
-(defun rcirc-handler-CTCP-response (process target sender message)
+(defun rcirc-handler-CTCP-response (process _target sender message)
(rcirc-print process sender "CTCP" nil message t))
(defgroup rcirc-faces nil
diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index dcc1654aba8..a0c9eba4144 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -33,11 +33,13 @@
(eval-when-compile (require 'cl))
(eval-when-compile (require 'url)) ;For url-filename's setf handler.
(require 'browse-url)
+(require 'subr-x)
+(require 'dom)
(defgroup shr nil
"Simple HTML Renderer"
- :version "24.1"
- :group 'hypermedia)
+ :version "25.1"
+ :group 'web)
(defcustom shr-max-image-proportion 0.9
"How big pictures displayed are in relation to the window they're in.
@@ -76,11 +78,12 @@ If nil, don't draw horizontal table lines."
:group 'shr
:type 'character)
-(defcustom shr-width fill-column
+(defcustom shr-width nil
"Frame width to use for 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."
+ :version "25.1"
:type '(choice (integer :tag "Fixed width in characters")
(const :tag "Use the width of the window" nil))
:group 'shr)
@@ -123,19 +126,24 @@ cid: URL as the argument.")
"Font for link elements."
:group 'shr)
+(defvar shr-inhibit-images nil
+ "If non-nil, inhibit loading images.")
+
;;; Internal variables.
(defvar shr-folding-mode nil)
(defvar shr-state nil)
(defvar shr-start nil)
(defvar shr-indentation 0)
-(defvar shr-inhibit-images nil)
+(defvar shr-internal-width (or shr-width (1- (window-width))))
(defvar shr-list-mode nil)
(defvar shr-content-cache nil)
(defvar shr-kinsoku-shorten nil)
(defvar shr-table-depth 0)
(defvar shr-stylesheet nil)
(defvar shr-base nil)
+(defvar shr-depth 0)
+(defvar shr-warning nil)
(defvar shr-ignore-cache nil)
(defvar shr-external-rendering-functions nil)
(defvar shr-target-id nil)
@@ -197,9 +205,13 @@ DOM should be a parse tree as generated by
(shr-state nil)
(shr-start nil)
(shr-base nil)
- (shr-width (or shr-width (1- (window-width)))))
- (shr-descend (shr-transform-dom dom))
- (shr-remove-trailing-whitespace start (point))))
+ (shr-depth 0)
+ (shr-warning nil)
+ (shr-internal-width (or shr-width (1- (window-width)))))
+ (shr-descend dom)
+ (shr-remove-trailing-whitespace start (point))
+ (when shr-warning
+ (message "%s" shr-warning))))
(defun shr-remove-trailing-whitespace (start end)
(let ((width (window-width)))
@@ -214,12 +226,16 @@ DOM should be a parse tree as generated by
(overlay-put overlay 'before-string nil))))
(forward-line 1)))))
-(defun shr-copy-url ()
+(defun shr-copy-url (&optional image-url)
"Copy the URL under point to the kill ring.
+If IMAGE-URL (the prefix) is non-nil, or there is no link under
+point, but there is an image under point then copy the URL of the
+image under point instead.
If called twice, then try to fetch the URL and see whether it
redirects somewhere else."
- (interactive)
- (let ((url (get-text-property (point) 'shr-url)))
+ (interactive "P")
+ (let ((url (or (get-text-property (point) 'shr-url)
+ (get-text-property (point) 'image-url))))
(cond
((not url)
(message "No URL under point"))
@@ -242,16 +258,17 @@ redirects somewhere else."
;; Copy the URL to the kill ring.
(t
(with-temp-buffer
- (insert url)
+ (insert (url-encode-url url))
(copy-region-as-kill (point-min) (point-max))
- (message "Copied %s" url))))))
+ (message "Copied %s" (buffer-string)))))))
(defun shr-next-link ()
"Skip to the next link."
(interactive)
(let ((skip (text-property-any (point) (point-max) 'help-echo nil)))
- (if (not (setq skip (text-property-not-all skip (point-max)
- 'help-echo nil)))
+ (if (or (eobp)
+ (not (setq skip (text-property-not-all skip (point-max)
+ 'help-echo nil))))
(message "No next link")
(goto-char skip)
(message "%s" (get-text-property (point) 'help-echo)))))
@@ -286,7 +303,7 @@ redirects somewhere else."
(let ((text (get-text-property (point) 'shr-alt)))
(if (not text)
(message "No image under point")
- (message "%s" text))))
+ (message "%s" (shr-fold-text text)))))
(defun shr-browse-image (&optional copy-url)
"Browse the image under point.
@@ -353,78 +370,80 @@ size, and full-buffer size."
;;; Utility functions.
-(defun shr-transform-dom (dom)
- (let ((result (list (pop dom))))
- (dolist (arg (pop dom))
- (push (cons (intern (concat ":" (symbol-name (car arg))) obarray)
- (cdr arg))
- result))
- (dolist (sub dom)
- (if (stringp sub)
- (push (cons 'text sub) result)
- (push (shr-transform-dom sub) result)))
- (nreverse result)))
-
-(defsubst shr-generic (cont)
- (dolist (sub cont)
- (cond
- ((eq (car sub) 'text)
- (shr-insert (cdr sub)))
- ((listp (cdr sub))
- (shr-descend sub)))))
+(defsubst shr-generic (dom)
+ (dolist (sub (dom-children dom))
+ (if (stringp sub)
+ (shr-insert sub)
+ (shr-descend sub))))
(defun shr-descend (dom)
(let ((function
(or
;; Allow other packages to override (or provide) rendering
;; of elements.
- (cdr (assq (car dom) shr-external-rendering-functions))
- (intern (concat "shr-tag-" (symbol-name (car dom))) obarray)))
- (style (cdr (assq :style (cdr dom))))
+ (cdr (assq (dom-tag dom) shr-external-rendering-functions))
+ (intern (concat "shr-tag-" (symbol-name (dom-tag dom))) obarray)))
+ (style (dom-attr dom 'style))
(shr-stylesheet shr-stylesheet)
+ (shr-depth (1+ shr-depth))
(start (point)))
- (when style
- (if (string-match "color\\|display\\|border-collapse" style)
- (setq shr-stylesheet (nconc (shr-parse-style style)
- shr-stylesheet))
- (setq style nil)))
- ;; If we have a display:none, then just ignore this part of the DOM.
- (unless (equal (cdr (assq 'display shr-stylesheet)) "none")
- (if (fboundp function)
- (funcall function (cdr dom))
- (shr-generic (cdr dom)))
- (when (and shr-target-id
- (equal (cdr (assq :id (cdr dom))) shr-target-id))
- ;; If the element was empty, we don't have anything to put the
- ;; anchor on. So just insert a dummy character.
- (when (= start (point))
- (insert "*"))
- (put-text-property start (1+ start) 'shr-target-id shr-target-id))
- ;; If style is set, then this node has set the color.
+ ;; shr uses about 12 frames per nested node.
+ (if (> shr-depth (/ max-specpdl-size 12))
+ (setq shr-warning "Too deeply nested to render properly; consider increasing `max-specpdl-size'")
(when style
- (shr-colorize-region start (point)
- (cdr (assq 'color shr-stylesheet))
- (cdr (assq 'background-color shr-stylesheet)))))))
-
-(defmacro shr-char-breakable-p (char)
+ (if (string-match "color\\|display\\|border-collapse" style)
+ (setq shr-stylesheet (nconc (shr-parse-style style)
+ shr-stylesheet))
+ (setq style nil)))
+ ;; If we have a display:none, then just ignore this part of the DOM.
+ (unless (equal (cdr (assq 'display shr-stylesheet)) "none")
+ (if (fboundp function)
+ (funcall function dom)
+ (shr-generic dom))
+ (when (and shr-target-id
+ (equal (dom-attr dom 'id) shr-target-id))
+ ;; If the element was empty, we don't have anything to put the
+ ;; anchor on. So just insert a dummy character.
+ (when (= start (point))
+ (insert "*"))
+ (put-text-property start (1+ start) 'shr-target-id shr-target-id))
+ ;; If style is set, then this node has set the color.
+ (when style
+ (shr-colorize-region
+ start (point)
+ (cdr (assq 'color shr-stylesheet))
+ (cdr (assq 'background-color shr-stylesheet))))))))
+
+(defun shr-fold-text (text)
+ (if (zerop (length text))
+ text
+ (with-temp-buffer
+ (let ((shr-indentation 0)
+ (shr-state nil)
+ (shr-start nil)
+ (shr-internal-width (window-width)))
+ (shr-insert text)
+ (buffer-string)))))
+
+(define-inline shr-char-breakable-p (char)
"Return non-nil if a line can be broken before and after CHAR."
- `(aref fill-find-break-point-function-table ,char))
-(defmacro shr-char-nospace-p (char)
+ (inline-quote (aref fill-find-break-point-function-table ,char)))
+(define-inline shr-char-nospace-p (char)
"Return non-nil if no space is required before and after CHAR."
- `(aref fill-nospace-between-words-table ,char))
+ (inline-quote (aref fill-nospace-between-words-table ,char)))
;; KINSOKU is a Japanese word meaning a rule that should not be violated.
;; In Emacs, it is a term used for characters, e.g. punctuation marks,
;; parentheses, and so on, that should not be placed in the beginning
;; of a line or the end of a line.
-(defmacro shr-char-kinsoku-bol-p (char)
+(define-inline shr-char-kinsoku-bol-p (char)
"Return non-nil if a line ought not to begin with CHAR."
- `(let ((char ,char))
- (and (not (eq char ?'))
- (aref (char-category-set char) ?>))))
-(defmacro shr-char-kinsoku-eol-p (char)
+ (inline-letevals (char)
+ (inline-quote (and (not (eq ,char ?'))
+ (aref (char-category-set ,char) ?>)))))
+(define-inline shr-char-kinsoku-eol-p (char)
"Return non-nil if a line ought not to end with CHAR."
- `(aref (char-category-set ,char) ?<))
+ (inline-quote (aref (char-category-set ,char) ?<)))
(unless (shr-char-kinsoku-bol-p (make-char 'japanese-jisx0208 33 35))
(load "kinsoku" nil t))
@@ -467,8 +486,8 @@ size, and full-buffer size."
(insert elem)
(setq shr-state nil)
(let (found)
- (while (and (> (current-column) shr-width)
- (> shr-width 0)
+ (while (and (> (current-column) shr-internal-width)
+ (> shr-internal-width 0)
(progn
(setq found (shr-find-fill-point))
(not (eolp))))
@@ -482,10 +501,10 @@ size, and full-buffer size."
(when (> shr-indentation 0)
(shr-indent))
(end-of-line))
- (if (<= (current-column) shr-width)
+ (if (<= (current-column) shr-internal-width)
(insert " ")
;; In case we couldn't get a valid break point (because of a
- ;; word that's longer than `shr-width'), just break anyway.
+ ;; word that's longer than `shr-internal-width'), just break anyway.
(insert "\n")
(when (> shr-indentation 0)
(shr-indent)))))
@@ -493,7 +512,7 @@ size, and full-buffer size."
(delete-char -1)))))
(defun shr-find-fill-point ()
- (when (> (move-to-column shr-width) shr-width)
+ (when (> (move-to-column shr-internal-width) shr-internal-width)
(backward-char 1))
(let ((bp (point))
failed)
@@ -533,7 +552,7 @@ size, and full-buffer size."
;; so we look for the second best position.
(while (and (progn
(forward-char 1)
- (<= (current-column) shr-width))
+ (<= (current-column) shr-internal-width))
(progn
(setq bp (point))
(shr-char-kinsoku-eol-p (following-char)))))
@@ -570,6 +589,8 @@ size, and full-buffer size."
;; Always chop off anchors.
(when (string-match "#.*" url)
(setq url (substring url 0 (match-beginning 0))))
+ ;; NB: <base href="" > URI may itself be relative to the document s URI
+ (setq url (shr-expand-url url))
(let* ((parsed (url-generic-parse-url url))
(local (url-filename parsed)))
(setf (url-filename parsed) "")
@@ -592,6 +613,7 @@ size, and full-buffer size."
(defun shr-expand-url (url &optional base)
(setq base
(if base
+ ;; shr-parse-base should never call this with non-nil base!
(shr-parse-base base)
;; Bound by the parser.
shr-base))
@@ -600,8 +622,8 @@ size, and full-buffer size."
(cond ((or (not url)
(not base)
(string-match "\\`[a-z]*:" url))
- ;; Absolute URL.
- (or url (car base)))
+ ;; Absolute or empty URI
+ (or url (nth 3 base)))
((eq (aref url 0) ?/)
(if (and (> (length url) 1)
(eq (aref url 1) ?/))
@@ -644,9 +666,9 @@ size, and full-buffer size."
(when (> shr-indentation 0)
(insert (make-string shr-indentation ? ))))
-(defun shr-fontize-cont (cont &rest types)
+(defun shr-fontize-dom (dom &rest types)
(let (shr-start)
- (shr-generic cont)
+ (shr-generic dom)
(dolist (type types)
(shr-add-font (or shr-start (point)) (point) type))))
@@ -759,6 +781,8 @@ element is the data blob and the second element is the content-type."
((eq size 'original)
(create-image data nil t :ascent 100
:format content-type))
+ ((eq content-type 'image/svg+xml)
+ (create-image data 'svg t :ascent 100))
((eq size 'full)
(ignore-errors
(shr-rescale-image data content-type)))
@@ -821,14 +845,24 @@ Return a string with image data."
(shr-parse-image-data)))))
(defun shr-parse-image-data ()
- (list
- (buffer-substring (point) (point-max))
- (save-excursion
- (save-restriction
- (narrow-to-region (point-min) (point))
- (let ((content-type (mail-fetch-field "content-type")))
- (and content-type
- (intern content-type obarray)))))))
+ (let ((data (buffer-substring (point) (point-max)))
+ (content-type
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (point-min) (point))
+ (let ((content-type (mail-fetch-field "content-type")))
+ (and content-type
+ ;; Remove any comments in the type string.
+ (intern (replace-regexp-in-string ";.*" "" content-type)
+ obarray)))))))
+ ;; SVG images may contain references to further images that we may
+ ;; want to block. So special-case these by parsing the XML data
+ ;; and remove the blocked bits.
+ (when (eq content-type 'image/svg+xml)
+ (setq data
+ (shr-dom-to-xml
+ (libxml-parse-xml-region (point) (point-max)))))
+ (list data content-type)))
(defun shr-image-displayer (content-function)
"Return a function to display an image.
@@ -850,9 +884,9 @@ START, and END. Note that START and END should be markers."
(list (current-buffer) start end)
t t)))))
-(defun shr-heading (cont &rest types)
+(defun shr-heading (dom &rest types)
(shr-ensure-paragraph)
- (apply #'shr-fontize-cont cont types)
+ (apply #'shr-fontize-dom dom types)
(shr-ensure-paragraph))
(defun shr-urlify (start url &optional title)
@@ -860,7 +894,12 @@ START, and END. Note that START and END should be markers."
(add-text-properties
start (point)
(list 'shr-url url
- 'help-echo (if title (format "%s (%s)" url title) url)
+ 'help-echo (let ((iri (or (ignore-errors
+ (decode-coding-string
+ (url-unhex-string url)
+ 'utf-8 t))
+ url)))
+ (if title (format "%s (%s)" iri title) iri))
'follow-link t
'mouse-face 'highlight
'keymap shr-map)))
@@ -961,105 +1000,106 @@ ones, in case fg and bg are nil."
;;; Tag-specific rendering rules.
-(defun shr-tag-body (cont)
+(defun shr-tag-body (dom)
(let* ((start (point))
- (fgcolor (cdr (or (assq :fgcolor cont)
- (assq :text cont))))
- (bgcolor (cdr (assq :bgcolor cont)))
+ (fgcolor (or (dom-attr dom 'fgcolor) (dom-attr dom 'text)))
+ (bgcolor (dom-attr dom 'bgcolor))
(shr-stylesheet (list (cons 'color fgcolor)
(cons 'background-color bgcolor))))
- (shr-generic cont)
+ (shr-generic dom)
(shr-colorize-region start (point) fgcolor bgcolor)))
-(defun shr-tag-style (_cont)
+(defun shr-tag-style (_dom)
)
-(defun shr-tag-script (_cont)
+(defun shr-tag-script (_dom)
)
-(defun shr-tag-comment (_cont)
+(defun shr-tag-comment (_dom)
)
(defun shr-dom-to-xml (dom)
+ (with-temp-buffer
+ (shr-dom-print dom)
+ (buffer-string)))
+
+(defun shr-dom-print (dom)
"Convert DOM into a string containing the xml representation."
- (let ((arg " ")
- (text "")
- url)
- (dolist (sub (cdr dom))
+ (insert (format "<%s" (dom-tag dom)))
+ (dolist (attr (dom-attributes dom))
+ ;; Ignore attributes that start with a colon because they are
+ ;; private elements.
+ (unless (= (aref (format "%s" (car attr)) 0) ?:)
+ (insert (format " %s=\"%s\"" (car attr) (cdr attr)))))
+ (insert ">")
+ (let (url)
+ (dolist (elem (dom-children dom))
(cond
- ((listp (cdr sub))
- ;; Ignore external image definitions if required.
- ;; <image xlink:href="http://TRACKING_URL/"/>
- (when (or (not (eq (car sub) 'image))
- (not (setq url (cdr (assq ':xlink:href (cdr sub)))))
- (not shr-blocked-images)
- (not (string-match shr-blocked-images url)))
- (setq text (concat text (shr-dom-to-xml sub)))))
- ((eq (car sub) 'text)
- (setq text (concat text (cdr sub))))
- (t
- (setq arg (concat arg (format "%s=\"%s\" "
- (substring (symbol-name (car sub)) 1)
- (cdr sub)))))))
- (format "<%s%s>%s</%s>"
- (car dom)
- (substring arg 0 (1- (length arg)))
- text
- (car dom))))
-
-(defun shr-tag-svg (cont)
+ ((stringp elem)
+ (insert elem))
+ ((eq (dom-tag elem) 'comment)
+ )
+ ((or (not (eq (dom-tag elem) 'image))
+ ;; Filter out blocked elements inside the SVG image.
+ (not (setq url (dom-attr elem ':xlink:href)))
+ (not shr-blocked-images)
+ (not (string-match shr-blocked-images url)))
+ (insert " ")
+ (shr-dom-print elem)))))
+ (insert (format "</%s>" (dom-tag dom))))
+
+(defun shr-tag-svg (dom)
(when (and (image-type-available-p 'svg)
(not shr-inhibit-images))
- (funcall shr-put-image-function
- (shr-dom-to-xml (cons 'svg cont))
- "SVG Image")))
+ (funcall shr-put-image-function (list (shr-dom-to-xml dom) 'image/svg+xml)
+ "SVG Image")))
-(defun shr-tag-sup (cont)
+(defun shr-tag-sup (dom)
(let ((start (point)))
- (shr-generic cont)
+ (shr-generic dom)
(put-text-property start (point) 'display '(raise 0.5))))
-(defun shr-tag-sub (cont)
+(defun shr-tag-sub (dom)
(let ((start (point)))
- (shr-generic cont)
+ (shr-generic dom)
(put-text-property start (point) 'display '(raise -0.5))))
-(defun shr-tag-label (cont)
- (shr-generic cont)
+(defun shr-tag-label (dom)
+ (shr-generic dom)
(shr-ensure-paragraph))
-(defun shr-tag-p (cont)
+(defun shr-tag-p (dom)
(shr-ensure-paragraph)
(shr-indent)
- (shr-generic cont)
+ (shr-generic dom)
(shr-ensure-paragraph))
-(defun shr-tag-div (cont)
+(defun shr-tag-div (dom)
(shr-ensure-newline)
(shr-indent)
- (shr-generic cont)
+ (shr-generic dom)
(shr-ensure-newline))
-(defun shr-tag-s (cont)
- (shr-fontize-cont cont 'shr-strike-through))
+(defun shr-tag-s (dom)
+ (shr-fontize-dom dom 'shr-strike-through))
-(defun shr-tag-del (cont)
- (shr-fontize-cont cont 'shr-strike-through))
+(defun shr-tag-del (dom)
+ (shr-fontize-dom dom 'shr-strike-through))
-(defun shr-tag-b (cont)
- (shr-fontize-cont cont 'bold))
+(defun shr-tag-b (dom)
+ (shr-fontize-dom dom 'bold))
-(defun shr-tag-i (cont)
- (shr-fontize-cont cont 'italic))
+(defun shr-tag-i (dom)
+ (shr-fontize-dom dom 'italic))
-(defun shr-tag-em (cont)
- (shr-fontize-cont cont 'italic))
+(defun shr-tag-em (dom)
+ (shr-fontize-dom dom 'italic))
-(defun shr-tag-strong (cont)
- (shr-fontize-cont cont 'bold))
+(defun shr-tag-strong (dom)
+ (shr-fontize-dom dom 'bold))
-(defun shr-tag-u (cont)
- (shr-fontize-cont cont 'underline))
+(defun shr-tag-u (dom)
+ (shr-fontize-dom dom 'underline))
(defun shr-parse-style (style)
(when style
@@ -1081,20 +1121,19 @@ ones, in case fg and bg are nil."
plist)))))
plist)))
-(defun shr-tag-base (cont)
- (let ((base (cdr (assq :href cont))))
- (when base
- (setq shr-base (shr-parse-base base))))
- (shr-generic cont))
+(defun shr-tag-base (dom)
+ (when-let (base (dom-attr dom 'href))
+ (setq shr-base (shr-parse-base base)))
+ (shr-generic dom))
-(defun shr-tag-a (cont)
- (let ((url (cdr (assq :href cont)))
- (title (cdr (assq :title cont)))
+(defun shr-tag-a (dom)
+ (let ((url (dom-attr dom 'href))
+ (title (dom-attr dom 'title))
(start (point))
shr-start)
- (shr-generic cont)
+ (shr-generic dom)
(when (and shr-target-id
- (equal (cdr (assq :name cont)) shr-target-id))
+ (equal (dom-attr dom 'name) shr-target-id))
;; We have a zero-length <a name="foo"> element, so just
;; insert... something.
(when (= start (point))
@@ -1105,19 +1144,33 @@ ones, in case fg and bg are nil."
(not shr-inhibit-decoration))
(shr-urlify (or shr-start start) (shr-expand-url url) title))))
-(defun shr-tag-object (cont)
- (let ((start (point))
- url)
- (dolist (elem cont)
- (when (eq (car elem) 'embed)
- (setq url (or url (cdr (assq :src (cdr elem))))))
- (when (and (eq (car elem) 'param)
- (equal (cdr (assq :name (cdr elem))) "movie"))
- (setq url (or url (cdr (assq :value (cdr elem)))))))
- (when url
- (shr-insert " [multimedia] ")
- (shr-urlify start (shr-expand-url url)))
- (shr-generic cont)))
+(defun shr-tag-object (dom)
+ (unless shr-inhibit-images
+ (let ((start (point))
+ url multimedia image)
+ (when-let (type (dom-attr dom 'type))
+ (when (string-match "\\`image/svg" type)
+ (setq url (dom-attr dom 'data)
+ image t)))
+ (dolist (child (dom-non-text-children dom))
+ (cond
+ ((eq (dom-tag child) 'embed)
+ (setq url (or url (dom-attr child 'src))
+ multimedia t))
+ ((and (eq (dom-tag child) 'param)
+ (equal (dom-attr child 'name) "movie"))
+ (setq url (or url (dom-attr child 'value))
+ multimedia t))))
+ (when url
+ (cond
+ (image
+ (shr-tag-img dom url)
+ (setq dom nil))
+ (multimedia
+ (shr-insert " [multimedia] ")
+ (shr-urlify start (shr-expand-url url)))))
+ (when dom
+ (shr-generic dom)))))
(defcustom shr-prefer-media-type-alist '(("webm" . 1.0)
("ogv" . 1.0)
@@ -1136,10 +1189,10 @@ url if no type is specified. The value should be a float in the range 0.0 to
(defun shr--get-media-pref (elem)
"Determine the preference for ELEM.
The preference is a float determined from `shr-prefer-media-type'."
- (let ((type (cdr (assq :type elem)))
+ (let ((type (dom-attr elem 'type))
(p 0.0))
(unless type
- (setq type (cdr (assq :src elem))))
+ (setq type (dom-attr elem 'src)))
(when type
(dolist (pref shr-prefer-media-type-alist)
(when (and
@@ -1148,61 +1201,61 @@ The preference is a float determined from `shr-prefer-media-type'."
(setq p (cdr pref)))))
p))
-(defun shr--extract-best-source (cont &optional url pref)
- "Extract the best `:src' property from <source> blocks in CONT."
+(defun shr--extract-best-source (dom &optional url pref)
+ "Extract the best `:src' property from <source> blocks in DOM."
(setq pref (or pref -1.0))
(let (new-pref)
- (dolist (elem cont)
- (when (and (eq (car elem) 'source)
+ (dolist (elem (dom-non-text-children dom))
+ (when (and (eq (dom-tag elem) 'source)
(< pref
(setq new-pref
(shr--get-media-pref elem))))
(setq pref new-pref
- url (cdr (assq :src elem)))
+ url (dom-attr elem 'src))
;; libxml's html parser isn't HTML5 compliant and non terminated
;; source tags might end up as children. So recursion it is...
- (dolist (child (cdr elem))
- (when (eq (car child) 'source)
+ (dolist (child (dom-non-text-children elem))
+ (when (eq (dom-tag child) 'source)
(let ((ret (shr--extract-best-source (list child) url pref)))
(when (< pref (cdr ret))
(setq url (car ret)
pref (cdr ret)))))))))
(cons url pref))
-(defun shr-tag-video (cont)
- (let ((image (cdr (assq :poster cont)))
- (url (cdr (assq :src cont)))
+(defun shr-tag-video (dom)
+ (let ((image (dom-attr dom 'poster))
+ (url (dom-attr dom 'src))
(start (point)))
(unless url
- (setq url (car (shr--extract-best-source cont))))
+ (setq url (car (shr--extract-best-source dom))))
(if image
(shr-tag-img nil image)
(shr-insert " [video] "))
(shr-urlify start (shr-expand-url url))))
-(defun shr-tag-audio (cont)
- (let ((url (cdr (assq :src cont)))
+(defun shr-tag-audio (dom)
+ (let ((url (dom-attr dom 'src))
(start (point)))
(unless url
- (setq url (car (shr--extract-best-source cont))))
+ (setq url (car (shr--extract-best-source dom))))
(shr-insert " [audio] ")
(shr-urlify start (shr-expand-url url))))
-(defun shr-tag-img (cont &optional url)
+(defun shr-tag-img (dom &optional url)
(when (or url
- (and cont
- (> (length (cdr (assq :src cont))) 0)))
+ (and dom
+ (> (length (dom-attr dom 'src)) 0)))
(when (and (> (current-column) 0)
(not (eq shr-state 'image)))
(insert "\n"))
- (let ((alt (cdr (assq :alt cont)))
- (url (shr-expand-url (or url (cdr (assq :src cont))))))
+ (let ((alt (dom-attr dom 'alt))
+ (url (shr-expand-url (or url (dom-attr dom 'src)))))
(let ((start (point-marker)))
(when (zerop (length alt))
(setq alt "*"))
(cond
- ((or (member (cdr (assq :height cont)) '("0" "1"))
- (member (cdr (assq :width cont)) '("0" "1")))
+ ((or (member (dom-attr dom 'height) '("0" "1"))
+ (member (dom-attr dom 'width) '("0" "1")))
;; Ignore zero-sized or single-pixel images.
)
((and (not shr-inhibit-images)
@@ -1248,52 +1301,51 @@ The preference is a float determined from `shr-prefer-media-type'."
(put-text-property start (point) 'image-displayer
(shr-image-displayer shr-content-function))
(put-text-property start (point) 'help-echo
- (or (cdr (assq :title cont))
- alt)))
+ (shr-fold-text (or (dom-attr dom 'title) alt))))
(setq shr-state 'image)))))
-(defun shr-tag-pre (cont)
+(defun shr-tag-pre (dom)
(let ((shr-folding-mode 'none))
(shr-ensure-newline)
(shr-indent)
- (shr-generic cont)
+ (shr-generic dom)
(shr-ensure-newline)))
-(defun shr-tag-blockquote (cont)
+(defun shr-tag-blockquote (dom)
(shr-ensure-paragraph)
(shr-indent)
(let ((shr-indentation (+ shr-indentation 4)))
- (shr-generic cont))
+ (shr-generic dom))
(shr-ensure-paragraph))
-(defun shr-tag-dl (cont)
+(defun shr-tag-dl (dom)
(shr-ensure-paragraph)
- (shr-generic cont)
+ (shr-generic dom)
(shr-ensure-paragraph))
-(defun shr-tag-dt (cont)
+(defun shr-tag-dt (dom)
(shr-ensure-newline)
- (shr-generic cont)
+ (shr-generic dom)
(shr-ensure-newline))
-(defun shr-tag-dd (cont)
+(defun shr-tag-dd (dom)
(shr-ensure-newline)
(let ((shr-indentation (+ shr-indentation 4)))
- (shr-generic cont)))
+ (shr-generic dom)))
-(defun shr-tag-ul (cont)
+(defun shr-tag-ul (dom)
(shr-ensure-paragraph)
(let ((shr-list-mode 'ul))
- (shr-generic cont))
+ (shr-generic dom))
(shr-ensure-paragraph))
-(defun shr-tag-ol (cont)
+(defun shr-tag-ol (dom)
(shr-ensure-paragraph)
(let ((shr-list-mode 1))
- (shr-generic cont))
+ (shr-generic dom))
(shr-ensure-paragraph))
-(defun shr-tag-li (cont)
+(defun shr-tag-li (dom)
(shr-ensure-newline)
(shr-indent)
(let* ((bullet
@@ -1304,9 +1356,9 @@ The preference is a float determined from `shr-prefer-media-type'."
shr-bullet))
(shr-indentation (+ shr-indentation (length bullet))))
(insert bullet)
- (shr-generic cont)))
+ (shr-generic dom)))
-(defun shr-tag-br (cont)
+(defun shr-tag-br (dom)
(when (and (not (bobp))
;; Only add a newline if we break the current line, or
;; the previous line isn't a blank line.
@@ -1315,42 +1367,42 @@ The preference is a float determined from `shr-prefer-media-type'."
(not (= (char-after (- (point) 2)) ?\n)))))
(insert "\n")
(shr-indent))
- (shr-generic cont))
+ (shr-generic dom))
-(defun shr-tag-span (cont)
- (shr-generic cont))
+(defun shr-tag-span (dom)
+ (shr-generic dom))
-(defun shr-tag-h1 (cont)
- (shr-heading cont 'bold 'underline))
+(defun shr-tag-h1 (dom)
+ (shr-heading dom 'bold 'underline))
-(defun shr-tag-h2 (cont)
- (shr-heading cont 'bold))
+(defun shr-tag-h2 (dom)
+ (shr-heading dom 'bold))
-(defun shr-tag-h3 (cont)
- (shr-heading cont 'italic))
+(defun shr-tag-h3 (dom)
+ (shr-heading dom 'italic))
-(defun shr-tag-h4 (cont)
- (shr-heading cont))
+(defun shr-tag-h4 (dom)
+ (shr-heading dom))
-(defun shr-tag-h5 (cont)
- (shr-heading cont))
+(defun shr-tag-h5 (dom)
+ (shr-heading dom))
-(defun shr-tag-h6 (cont)
- (shr-heading cont))
+(defun shr-tag-h6 (dom)
+ (shr-heading dom))
-(defun shr-tag-hr (_cont)
+(defun shr-tag-hr (_dom)
(shr-ensure-newline)
- (insert (make-string shr-width shr-hr-line) "\n"))
+ (insert (make-string shr-internal-width shr-hr-line) "\n"))
-(defun shr-tag-title (cont)
- (shr-heading cont 'bold 'underline))
+(defun shr-tag-title (dom)
+ (shr-heading dom 'bold 'underline))
-(defun shr-tag-font (cont)
+(defun shr-tag-font (dom)
(let* ((start (point))
- (color (cdr (assq :color cont)))
+ (color (dom-attr dom 'color))
(shr-stylesheet (nconc (list (cons 'color color))
shr-stylesheet)))
- (shr-generic cont)
+ (shr-generic dom)
(when color
(shr-colorize-region start (point) color
(cdr (assq 'background-color shr-stylesheet))))))
@@ -1365,23 +1417,22 @@ The preference is a float determined from `shr-prefer-media-type'."
;; main buffer). Now we know how much space each TD really takes, so
;; we then render everything again with the new widths, and finally
;; insert all these boxes into the main buffer.
-(defun shr-tag-table-1 (cont)
- (setq cont (or (cdr (assq 'tbody cont))
- cont))
+(defun shr-tag-table-1 (dom)
+ (setq dom (or (dom-child-by-tag dom 'tbody) dom))
(let* ((shr-inhibit-images t)
(shr-table-depth (1+ shr-table-depth))
(shr-kinsoku-shorten t)
;; Find all suggested widths.
- (columns (shr-column-specs cont))
+ (columns (shr-column-specs dom))
;; Compute how many characters wide each TD should be.
(suggested-widths (shr-pro-rate-columns columns))
;; Do a "test rendering" to see how big each TD is (this can
;; be smaller (if there's little text) or bigger (if there's
;; unbreakable text).
- (sketch (shr-make-table cont suggested-widths))
+ (sketch (shr-make-table dom suggested-widths))
;; Compute the "natural" width by setting each column to 500
;; characters and see how wide they really render.
- (natural (shr-make-table cont (make-vector (length columns) 500)))
+ (natural (shr-make-table dom (make-vector (length columns) 500)))
(sketch-widths (shr-table-widths sketch natural suggested-widths)))
;; This probably won't work very well.
(when (> (+ (loop for width across sketch-widths
@@ -1390,15 +1441,16 @@ The preference is a float determined from `shr-prefer-media-type'."
(frame-width))
(setq truncate-lines t))
;; Then render the table again with these new "hard" widths.
- (shr-insert-table (shr-make-table cont sketch-widths t) sketch-widths)))
+ (shr-insert-table (shr-make-table dom sketch-widths t) sketch-widths)))
-(defun shr-tag-table (cont)
+(defun shr-tag-table (dom)
(shr-ensure-paragraph)
- (let* ((caption (cdr (assq 'caption cont)))
- (header (cdr (assq 'thead cont)))
- (body (or (cdr (assq 'tbody cont)) cont))
- (footer (cdr (assq 'tfoot cont)))
- (bgcolor (cdr (assq :bgcolor cont)))
+ (let* ((caption (dom-children (dom-child-by-tag dom 'caption)))
+ (header (dom-non-text-children (dom-child-by-tag dom 'thead)))
+ (body (dom-non-text-children (or (dom-child-by-tag dom 'tbody)
+ dom)))
+ (footer (dom-non-text-children (dom-child-by-tag dom 'tfoot)))
+ (bgcolor (dom-attr dom 'bgcolor))
(start (point))
(shr-stylesheet (nconc (list (cons 'background-color bgcolor))
shr-stylesheet))
@@ -1407,51 +1459,71 @@ The preference is a float determined from `shr-prefer-media-type'."
(nfooter (if footer (shr-max-columns footer))))
(if (and (not caption)
(not header)
- (not (cdr (assq 'tbody cont)))
- (not (cdr (assq 'tr cont)))
+ (not (dom-child-by-tag dom 'tbody))
+ (not (dom-child-by-tag dom 'tr))
(not footer))
;; The table is totally invalid and just contains random junk.
;; Try to output it anyway.
- (shr-generic cont)
+ (shr-generic dom)
;; It's a real table, so render it.
(shr-tag-table-1
(nconc
- (if caption `((tr (td ,@caption))))
- (if header
- (if footer
- ;; header + body + footer
- (if (= nheader nbody)
- (if (= nbody nfooter)
- `((tr (td (table (tbody ,@header ,@body ,@footer)))))
- (nconc `((tr (td (table (tbody ,@header ,@body)))))
- (if (= nfooter 1)
- footer
- `((tr (td (table (tbody ,@footer))))))))
- (nconc `((tr (td (table (tbody ,@header)))))
- (if (= nbody nfooter)
- `((tr (td (table (tbody ,@body ,@footer)))))
- (nconc `((tr (td (table (tbody ,@body)))))
- (if (= nfooter 1)
- footer
- `((tr (td (table (tbody ,@footer))))))))))
- ;; header + body
- (if (= nheader nbody)
- `((tr (td (table (tbody ,@header ,@body)))))
- (if (= nheader 1)
- `(,@header (tr (td (table (tbody ,@body)))))
- `((tr (td (table (tbody ,@header))))
- (tr (td (table (tbody ,@body))))))))
- (if footer
- ;; body + footer
- (if (= nbody nfooter)
- `((tr (td (table (tbody ,@body ,@footer)))))
- (nconc `((tr (td (table (tbody ,@body)))))
- (if (= nfooter 1)
- footer
- `((tr (td (table (tbody ,@footer))))))))
- (if caption
- `((tr (td (table (tbody ,@body)))))
- body))))))
+ (list 'table nil)
+ (if caption `((tr nil (td nil ,@caption))))
+ (cond (header
+ (if footer
+ ;; header + body + footer
+ (if (= nheader nbody)
+ (if (= nbody nfooter)
+ `((tr nil (td nil (table nil
+ (tbody nil ,@header
+ ,@body ,@footer)))))
+ (nconc `((tr nil (td nil (table nil
+ (tbody nil ,@header
+ ,@body)))))
+ (if (= nfooter 1)
+ footer
+ `((tr nil (td nil (table
+ nil (tbody
+ nil ,@footer))))))))
+ (nconc `((tr nil (td nil (table nil (tbody
+ nil ,@header)))))
+ (if (= nbody nfooter)
+ `((tr nil (td nil (table
+ nil (tbody nil ,@body
+ ,@footer)))))
+ (nconc `((tr nil (td nil (table
+ nil (tbody nil
+ ,@body)))))
+ (if (= nfooter 1)
+ footer
+ `((tr nil (td nil (table
+ nil
+ (tbody
+ nil
+ ,@footer))))))))))
+ ;; header + body
+ (if (= nheader nbody)
+ `((tr nil (td nil (table nil (tbody nil ,@header
+ ,@body)))))
+ (if (= nheader 1)
+ `(,@header (tr nil (td nil (table
+ nil (tbody nil ,@body)))))
+ `((tr nil (td nil (table nil (tbody nil ,@header))))
+ (tr nil (td nil (table nil (tbody nil ,@body)))))))))
+ (footer
+ ;; body + footer
+ (if (= nbody nfooter)
+ `((tr nil (td nil (table
+ nil (tbody nil ,@body ,@footer)))))
+ (nconc `((tr nil (td nil (table nil (tbody nil ,@body)))))
+ (if (= nfooter 1)
+ footer
+ `((tr nil (td nil (table
+ nil (tbody nil ,@footer)))))))))
+ (caption
+ `((tr nil (td nil (table nil (tbody nil ,@body))))))
+ (body)))))
(when bgcolor
(shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet))
bgcolor))
@@ -1459,17 +1531,10 @@ The preference is a float determined from `shr-prefer-media-type'."
;; model isn't strong enough to allow us to put the images actually
;; into the tables.
(when (zerop shr-table-depth)
- (dolist (elem (shr-find-elements cont 'img))
- (shr-tag-img (cdr elem))))))
-
-(defun shr-find-elements (cont type)
- (let (result)
- (dolist (elem cont)
- (cond ((eq (car elem) type)
- (push elem result))
- ((consp (cdr elem))
- (setq result (nconc (shr-find-elements (cdr elem) type) result)))))
- (nreverse result)))
+ (dolist (elem (dom-by-tag dom 'object))
+ (shr-tag-object elem))
+ (dolist (elem (dom-by-tag dom 'img))
+ (shr-tag-img elem)))))
(defun shr-insert-table (table widths)
(let* ((collapse (equal (cdr (assq 'border-collapse shr-stylesheet))
@@ -1552,22 +1617,22 @@ The preference is a float determined from `shr-prefer-media-type'."
(aref widths i))))))))
widths))
-(defun shr-make-table (cont widths &optional fill)
- (or (cadr (assoc (list cont widths fill) shr-content-cache))
- (let ((data (shr-make-table-1 cont widths fill)))
- (push (list (list cont widths fill) data)
+(defun shr-make-table (dom widths &optional fill)
+ (or (cadr (assoc (list dom widths fill) shr-content-cache))
+ (let ((data (shr-make-table-1 dom widths fill)))
+ (push (list (list dom widths fill) data)
shr-content-cache)
data)))
-(defun shr-make-table-1 (cont widths &optional fill)
+(defun shr-make-table-1 (dom widths &optional fill)
(let ((trs nil)
(shr-inhibit-decoration (not fill))
(rowspans (make-vector (length widths) 0))
width colspan)
- (dolist (row cont)
- (when (eq (car row) 'tr)
+ (dolist (row (dom-non-text-children dom))
+ (when (eq (dom-tag row) 'tr)
(let ((tds nil)
- (columns (cdr row))
+ (columns (dom-children row))
(i 0)
(width-column 0)
column)
@@ -1581,12 +1646,12 @@ The preference is a float determined from `shr-prefer-media-type'."
(pop columns)
(aset rowspans i (1- (aref rowspans i)))
'(td)))
- (when (or (memq (car column) '(td th))
- (not column))
- (when (cdr (assq :rowspan (cdr column)))
+ (when (and (not (stringp column))
+ (or (memq (dom-tag column) '(td th))
+ (not column)))
+ (when-let (span (dom-attr column 'rowspan))
(aset rowspans i (+ (aref rowspans i)
- (1- (string-to-number
- (cdr (assq :rowspan (cdr column))))))))
+ (1- (string-to-number span)))))
;; Sanity check for invalid column-spans.
(when (>= width-column (length widths))
(setq width-column 0))
@@ -1595,7 +1660,7 @@ The preference is a float determined from `shr-prefer-media-type'."
(aref widths width-column)
10))
(when (and fill
- (setq colspan (cdr (assq :colspan (cdr column)))))
+ (setq colspan (dom-attr column 'colspan)))
(setq colspan (min (string-to-number colspan)
;; The colspan may be wrong, so
;; truncate it to the length of the
@@ -1610,18 +1675,18 @@ The preference is a float determined from `shr-prefer-media-type'."
(setq width-column (+ width-column (1- colspan))))
(when (or column
(not fill))
- (push (shr-render-td (cdr column) width fill)
+ (push (shr-render-td column width fill)
tds))
(setq i (1+ i)
width-column (1+ width-column))))
(push (nreverse tds) trs))))
(nreverse trs)))
-(defun shr-render-td (cont width fill)
+(defun shr-render-td (dom width fill)
(with-temp-buffer
- (let ((bgcolor (cdr (assq :bgcolor cont)))
- (fgcolor (cdr (assq :fgcolor cont)))
- (style (cdr (assq :style cont)))
+ (let ((bgcolor (dom-attr dom 'bgcolor))
+ (fgcolor (dom-attr dom 'fgcolor))
+ (style (dom-attr dom 'style))
(shr-stylesheet shr-stylesheet)
actual-colors)
(when style
@@ -1633,9 +1698,9 @@ The preference is a float determined from `shr-prefer-media-type'."
(setq style (nconc (list (cons 'color fgcolor)) style)))
(when style
(setq shr-stylesheet (append style shr-stylesheet)))
- (let ((shr-width width)
+ (let ((shr-internal-width width)
(shr-indentation 0))
- (shr-descend (cons 'td cont)))
+ (shr-descend dom))
;; Delete padding at the bottom of the TDs.
(delete-region
(point)
@@ -1656,7 +1721,7 @@ The preference is a float determined from `shr-prefer-media-type'."
(if (zerop (buffer-size))
(insert (make-string width ? ))
;; Otherwise, fill the buffer.
- (let ((align (cdr (assq :align cont)))
+ (let ((align (dom-attr dom 'align))
length)
(while (not (eobp))
(end-of-line)
@@ -1705,19 +1770,21 @@ The preference is a float determined from `shr-prefer-media-type'."
(dotimes (i (length columns))
(aset widths i (max (truncate (* (aref columns i)
total-percentage
- (- shr-width (1+ (length columns)))))
+ (- shr-internal-width
+ (1+ (length columns)))))
10)))
widths))
;; Return a summary of the number and shape of the TDs in the table.
-(defun shr-column-specs (cont)
- (let ((columns (make-vector (shr-max-columns cont) 1)))
- (dolist (row cont)
- (when (eq (car row) 'tr)
+(defun shr-column-specs (dom)
+ (let ((columns (make-vector (shr-max-columns dom) 1)))
+ (dolist (row (dom-non-text-children dom))
+ (when (eq (dom-tag row) 'tr)
(let ((i 0))
- (dolist (column (cdr row))
- (when (memq (car column) '(td th))
- (let ((width (cdr (assq :width (cdr column)))))
+ (dolist (column (dom-children row))
+ (when (and (not (stringp column))
+ (memq (dom-tag column) '(td th)))
+ (let ((width (dom-attr column 'width)))
(when (and width
(string-match "\\([0-9]+\\)%" width)
(not (zerop (setq width (string-to-number
@@ -1726,19 +1793,21 @@ The preference is a float determined from `shr-prefer-media-type'."
(setq i (1+ i)))))))
columns))
-(defun shr-count (cont elem)
+(defun shr-count (dom elem)
(let ((i 0))
- (dolist (sub cont)
- (when (eq (car sub) elem)
+ (dolist (sub (dom-children dom))
+ (when (and (not (stringp sub))
+ (eq (dom-tag sub) elem))
(setq i (1+ i))))
i))
-(defun shr-max-columns (cont)
+(defun shr-max-columns (dom)
(let ((max 0))
- (dolist (row cont)
- (when (eq (car row) 'tr)
- (setq max (max max (+ (shr-count (cdr row) 'td)
- (shr-count (cdr row) 'th))))))
+ (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))))))
max))
(provide 'shr)
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index 8e65686e353..80a256c8d3b 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -65,6 +65,22 @@ files conditionalize this setup based on the TERM environment variable."
:type 'string)
;;;###tramp-autoload
+(defcustom tramp-histfile-override "/dev/null"
+ "When invoking a shell, override the HISTFILE with this value.
+By default, the HISTFILE is set to the \"/dev/null\" value, which
+is special on Unix systems and indicates the shell history should
+not be logged (this avoids clutter due to Tramp commands).
+
+If you set this variable to nil, however, the *override* is
+disabled, so the history will go to the default storage
+location, e.g. \"$HOME/.sh_history\"."
+ :group 'tramp
+ :version "25.1"
+ :type '(choice (const :tag "Do not override HISTFILE" nil)
+ (const :tag "Empty the history (/dev/null)" "/dev/null")
+ (string :tag "Redirect to a file")))
+
+;;;###tramp-autoload
(defconst tramp-color-escape-sequence-regexp "\e[[;0-9]+m"
"Escape sequences produced by the \"ls\" command.")
@@ -2839,16 +2855,27 @@ the result will be a local, non-Tramp, file name."
(list (replace-match " \\\\\n" nil nil (cadr args))))
(setq i (+ i 250))))
(cdr args)))
+ ;; Use a human-friendly prompt, for example for `shell'.
+ (prompt (format "PS1=%s"
+ (format "%s %s"
+ (file-remote-p default-directory)
+ tramp-initial-end-of-output)))
+ ;; We use as environment the difference to toplevel
+ ;; `process-environment'.
+ env
+ (env
+ (dolist
+ (elt
+ (cons prompt (nreverse (copy-sequence process-environment)))
+ env)
+ (or (member elt (default-toplevel-value 'process-environment))
+ (setq env (cons elt env)))))
(command
(when (stringp program)
- (format "cd %s && exec %s env PS1=%s %s"
+ (format "cd %s && exec %s env %s %s"
(tramp-shell-quote-argument localname)
(if heredoc (format "<<'%s'" tramp-end-of-heredoc) "")
- ;; Use a human-friendly prompt, for example for `shell'.
- (tramp-shell-quote-argument
- (format "%s %s"
- (file-remote-p default-directory)
- tramp-initial-end-of-output))
+ (mapconcat 'tramp-shell-quote-argument env " ")
(if heredoc
(format "%s\n(\n%s\n) </dev/tty\n%s"
program (car args) tramp-end-of-heredoc)
@@ -2935,10 +2962,20 @@ the result will be a local, non-Tramp, file name."
(error "Implementation does not handle immediate return"))
(with-parsed-tramp-file-name default-directory nil
- (let (command input tmpinput stderr tmpstderr outbuf ret)
+ (let (command env input tmpinput stderr tmpstderr outbuf ret)
;; Compute command.
(setq command (mapconcat 'tramp-shell-quote-argument
(cons program args) " "))
+ ;; We use as environment the difference to toplevel `process-environment'.
+ (setq env
+ (dolist (elt (nreverse (copy-sequence process-environment)) env)
+ (or (member elt (default-toplevel-value 'process-environment))
+ (setq env (cons elt env)))))
+ (when env
+ (setq command
+ (format
+ "env %s %s"
+ (mapconcat 'tramp-shell-quote-argument env " ") command)))
;; Determine input.
(if (null infile)
(setq input "/dev/null")
@@ -3865,7 +3902,10 @@ file exists and nonzero exit status otherwise."
;; the prompt in /bin/bash, it must be discarded as well.
(tramp-send-command
vec (format
- "exec env ENV='' HISTFILE=/dev/null PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s"
+ "exec env ENV=''%s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s"
+ (if tramp-histfile-override
+ (concat " HISTFILE=" tramp-histfile-override)
+ "")
(tramp-shell-quote-argument tramp-end-of-output)
shell (or extra-args ""))
t))
@@ -4587,7 +4627,8 @@ connection if a previous connection has died for some reason."
(delete-process p))
(setenv "TERM" tramp-terminal-type)
(setenv "LC_ALL" "en_US.utf8")
- (setenv "HISTFILE" "/dev/null")
+ (when tramp-histfile-override
+ (setenv "HISTFILE" tramp-histfile-override))
(setenv "PROMPT_COMMAND")
(setenv "PS1" tramp-initial-end-of-output)
(let* ((target-alist (tramp-compute-multi-hops vec))
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index 3afb487ec3d..ba0d13eab8b 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -3228,7 +3228,7 @@ User is always nil."
t)))
(defun tramp-handle-make-symbolic-link
- (filename linkname &optional ok-if-already-exists)
+ (filename linkname &optional _ok-if-already-exists)
"Like `make-symbolic-link' for Tramp files."
(with-parsed-tramp-file-name
(if (tramp-tramp-file-p filename) filename linkname) nil
generated by cgit v1.2.3 (git 2.39.1) at 2025-05-02 14:26:50 +0000