diff options
Diffstat (limited to 'lisp/net')
| -rw-r--r-- | lisp/net/eudc-bob.el | 130 | ||||
| -rw-r--r-- | lisp/net/eww.el | 25 | ||||
| -rw-r--r-- | lisp/net/newst-treeview.el | 30 | ||||
| -rw-r--r-- | lisp/net/ntlm.el | 44 | ||||
| -rw-r--r-- | lisp/net/tramp-sh.el | 98 | ||||
| -rw-r--r-- | lisp/net/tramp.el | 103 |
6 files changed, 190 insertions, 240 deletions
diff --git a/lisp/net/eudc-bob.el b/lisp/net/eudc-bob.el index 56ea033a963..bb6682520ae 100644 --- a/lisp/net/eudc-bob.el +++ b/lisp/net/eudc-bob.el @@ -1,4 +1,4 @@ -;;; eudc-bob.el --- Binary Objects Support for EUDC +;;; eudc-bob.el --- Binary Objects Support for EUDC -*- lexical-binding: t; -*- ;; Copyright (C) 1999-2020 Free Software Foundation, Inc. @@ -39,19 +39,41 @@ (require 'eudc) -(defvar eudc-bob-generic-keymap nil +(defvar eudc-bob-generic-keymap + (let ((map (make-sparse-keymap))) + (define-key map "s" 'eudc-bob-save-object) + (define-key map "!" 'eudc-bob-pipe-object-to-external-program) + (define-key map [down-mouse-3] 'eudc-bob-popup-menu) + map) "Keymap for multimedia objects.") -(defvar eudc-bob-image-keymap nil +(defvar eudc-bob-image-keymap + (let ((map (make-sparse-keymap))) + (set-keymap-parent map eudc-bob-generic-keymap) + (define-key map "t" 'eudc-bob-toggle-inline-display) + map) "Keymap for inline images.") -(defvar eudc-bob-sound-keymap nil +(defvar eudc-bob-sound-keymap + (let ((map (make-sparse-keymap))) + (set-keymap-parent map eudc-bob-generic-keymap) + (define-key map (kbd "RET") 'eudc-bob-play-sound-at-point) + (define-key map [down-mouse-2] 'eudc-bob-play-sound-at-mouse) + map) "Keymap for inline sounds.") -(defvar eudc-bob-url-keymap nil +(defvar eudc-bob-url-keymap + (let ((map (make-sparse-keymap))) + (define-key map (kbd "RET") 'browse-url-at-point) + (define-key map [down-mouse-2] 'browse-url-at-mouse) + map) "Keymap for inline urls.") -(defvar eudc-bob-mail-keymap nil +(defvar eudc-bob-mail-keymap + (let ((map (make-sparse-keymap))) + (define-key map (kbd "RET") 'goto-address-at-point) + (define-key map [down-mouse-2] 'goto-address-at-point) + map) "Keymap for inline e-mail addresses.") (defvar eudc-bob-generic-menu @@ -74,13 +96,6 @@ (fboundp 'play-sound-internal)] ,@(cdr (cdr eudc-bob-generic-menu)))) -(defun eudc-jump-to-event (event) - "Jump to the window and point where EVENT occurred." - (if (fboundp 'event-closest-point) - (goto-char (event-closest-point event)) - (set-buffer (window-buffer (posn-window (event-start event)))) - (goto-char (posn-point (event-start event))))) - (defun eudc-bob-get-overlay-prop (prop) "Get property PROP from one of the overlays around." (let ((overlays (append (overlays-at (1- (point))) @@ -205,42 +220,30 @@ display a button." "Play the sound data contained in the button where EVENT occurred." (interactive "e") (save-excursion - (eudc-jump-to-event event) + (mouse-set-point event) (eudc-bob-play-sound-at-point))) -(defun eudc-bob-save-object () +(defun eudc-bob-save-object (filename) "Save the object data of the button at point." - (interactive) + (interactive "fWrite file: ") (let ((data (eudc-bob-get-overlay-prop 'object-data)) - (buffer (generate-new-buffer "*eudc-tmp*"))) - (save-excursion - (set-buffer-file-coding-system 'binary) - (set-buffer buffer) - (set-buffer-multibyte nil) - (insert data) - (save-buffer)) - (kill-buffer buffer))) + (coding-system-for-write 'binary)) ;Inhibit EOL conversion. + (write-region data nil filename))) -(defun eudc-bob-pipe-object-to-external-program () +(defun eudc-bob-pipe-object-to-external-program (program) "Pipe the object data of the button at point to an external program." - (interactive) + (interactive (list (completing-read "Viewer: " eudc-external-viewers))) (let ((data (eudc-bob-get-overlay-prop 'object-data)) - (buffer (generate-new-buffer "*eudc-tmp*")) - program - viewer) - (condition-case nil - (save-excursion - (set-buffer-file-coding-system 'binary) - (set-buffer buffer) - (insert data) - (setq program (completing-read "Viewer: " eudc-external-viewers)) - (if (setq viewer (assoc program eudc-external-viewers)) - (call-process-region (point-min) (point-max) - (car (cdr viewer)) - (cdr (cdr viewer))) - (call-process-region (point-min) (point-max) program))) - (error - (kill-buffer buffer))))) + (viewer (assoc program eudc-external-viewers))) + (with-temp-buffer + (set-buffer-multibyte nil) + (insert data) + (let ((coding-system-for-write 'binary)) ;Inhibit EOL conversion + (if viewer + (call-process-region (point-min) (point-max) + (car (cdr viewer)) + (cdr (cdr viewer))) + (call-process-region (point-min) (point-max) program)))))) (defun eudc-bob-menu () "Retrieve the menu attached to a binary object." @@ -250,47 +253,8 @@ display a button." "Pop-up a menu of EUDC multimedia commands." (interactive "@e") (run-hooks 'activate-menubar-hook) - (eudc-jump-to-event event) - (let ((result (x-popup-menu t (eudc-bob-menu))) - command) - (if result - (progn - (setq command (lookup-key (eudc-bob-menu) - (apply 'vector result))) - (command-execute command))))) - -(setq eudc-bob-generic-keymap - (let ((map (make-sparse-keymap))) - (define-key map "s" 'eudc-bob-save-object) - (define-key map "!" 'eudc-bob-pipe-object-to-external-program) - (define-key map [down-mouse-3] 'eudc-bob-popup-menu) - map)) - -(setq eudc-bob-image-keymap - (let ((map (make-sparse-keymap))) - (define-key map "t" 'eudc-bob-toggle-inline-display) - map)) - -(setq eudc-bob-sound-keymap - (let ((map (make-sparse-keymap))) - (define-key map [return] 'eudc-bob-play-sound-at-point) - (define-key map [down-mouse-2] 'eudc-bob-play-sound-at-mouse) - map)) - -(setq eudc-bob-url-keymap - (let ((map (make-sparse-keymap))) - (define-key map [return] 'browse-url-at-point) - (define-key map [down-mouse-2] 'browse-url-at-mouse) - map)) - -(setq eudc-bob-mail-keymap - (let ((map (make-sparse-keymap))) - (define-key map [return] 'goto-address-at-point) - (define-key map [down-mouse-2] 'goto-address-at-point) - map)) - -(set-keymap-parent eudc-bob-image-keymap eudc-bob-generic-keymap) -(set-keymap-parent eudc-bob-sound-keymap eudc-bob-generic-keymap) + (mouse-set-point event) + (popup-menu (eudc-bob-menu) event)) ;; If the first arguments can be nil here, then these 3 can be ;; defconsts once more. diff --git a/lisp/net/eww.el b/lisp/net/eww.el index e7170b3e6d1..04deb5bee05 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -672,9 +672,30 @@ Currently this means either text/html or application/xhtml+xml." (setq header-line-format (and eww-header-line-format (let ((title (plist-get eww-data :title)) - (peer (plist-get eww-data :peer))) + (peer (plist-get eww-data :peer)) + (url (plist-get eww-data :url))) (when (zerop (length title)) (setq title "[untitled]")) + ;; Limit the length of the title so that the host name + ;; of the URL is always visible. + (when url + (let* ((parsed (url-generic-parse-url url)) + (host-length (length (format "%s://%s" + (url-type parsed) + (url-host parsed)))) + (width (window-width))) + (cond + ;; The host bit is wider than the window, so nix + ;; the title. + ((> (+ host-length 5) width) + (setq title "")) + ;; Trim the title. + ((> (+ (length title) host-length 2) width) + (setq title (concat + (substring title 0 (- width + host-length + 5)) + "...")))))) ;; This connection has is https. (when peer (setq title @@ -686,7 +707,7 @@ Currently this means either text/html or application/xhtml+xml." "%" "%%" (format-spec eww-header-line-format - `((?u . ,(or (plist-get eww-data :url) "")) + `((?u . ,(or url "")) (?t . ,title)))))))) (defun eww-tag-title (dom) diff --git a/lisp/net/newst-treeview.el b/lisp/net/newst-treeview.el index 1bed61f3e7d..ff8a447c7c1 100644 --- a/lisp/net/newst-treeview.el +++ b/lisp/net/newst-treeview.el @@ -131,14 +131,6 @@ groupcontent := feedname | groupdefinition) Example: (\"Topmost group\" \"feed1\" (\"subgroup1\" \"feed 2\") \"feed3\")") -(defcustom newsticker-groups-filename - nil - "Name of the newsticker groups settings file." - :version "25.1" ; changed default value to nil - :type '(choice (const nil) string) - :group 'newsticker-treeview) -(make-obsolete-variable 'newsticker-groups-filename 'newsticker-dir "23.1") - ;; ====================================================================== ;;; internal variables ;; ====================================================================== @@ -1265,29 +1257,9 @@ Note: does not update the layout." (defun newsticker--treeview-load () "Load treeview settings." (let* ((coding-system-for-read 'utf-8) - (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-message - (concat "Obsolete variable `newsticker-groups-filename' " - "points to existing file \"%s\".\n" - "Read it? ") - newsticker-groups-filename)) - newsticker-groups-filename) - (concat newsticker-dir "/groups"))) + (filename (concat newsticker-dir "/groups")) (buf (and (file-exists-p filename) (find-file-noselect filename)))) - (and newsticker-groups-filename - (file-exists-p newsticker-groups-filename) - (y-or-n-p (format-message - (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) (goto-char (point-min)) diff --git a/lisp/net/ntlm.el b/lisp/net/ntlm.el index ebcd21948bf..9401430799c 100644 --- a/lisp/net/ntlm.el +++ b/lisp/net/ntlm.el @@ -69,7 +69,6 @@ (require 'md4) (require 'hmac-md5) -(require 'calc) (defgroup ntlm nil "NTLM (NT LanManager) authentication." @@ -133,32 +132,27 @@ is not given." domain ;buffer field )))) -(defun ntlm-compute-timestamp () - "Compute an NTLMv2 timestamp. +(defun ntlm--time-to-timestamp (time) + "Convert TIME to an NTLMv2 timestamp. Return a unibyte string representing the number of tenths of a microsecond since January 1, 1601 as a 64-bit little-endian -signed integer." - ;; FIXME: This can likely be significantly simplified using the new - ;; bignums support! - (let* ((s-to-tenths-of-us "mul(add(lsh($1,16),$2),10000000)") - (us-to-tenths-of-us "mul($3,10)") - (ps-to-tenths-of-us "idiv($4,100000)") - (tenths-of-us-since-jan-1-1601 - (apply #'calc-eval (concat "add(add(add(" - s-to-tenths-of-us "," - us-to-tenths-of-us ")," - ps-to-tenths-of-us ")," - ;; tenths of microseconds between - ;; 1601-01-01 and 1970-01-01 - "116444736000000000)") - 'rawnum (time-convert nil 'list))) - result-bytes) - (dotimes (_byte 8) - (push (calc-eval "and($1,16#FF)" 'rawnum tenths-of-us-since-jan-1-1601) - result-bytes) - (setq tenths-of-us-since-jan-1-1601 - (calc-eval "rsh($1,8,64)" 'rawnum tenths-of-us-since-jan-1-1601))) - (apply #'unibyte-string (nreverse result-bytes)))) +signed integer. TIME must be on the form (HIGH LOW USEC PSEC)." + (let* ((s (+ (ash (nth 0 time) 16) (nth 1 time))) + (us (nth 2 time)) + (ps (nth 3 time)) + (tenths-of-us-since-jan-1-1601 + (+ (* s 10000000) (* us 10) (/ ps 100000) + ;; tenths of microseconds between 1601-01-01 and 1970-01-01 + 116444736000000000))) + (apply #'unibyte-string + (mapcar (lambda (i) + (logand (ash tenths-of-us-since-jan-1-1601 (* i -8)) + #xff)) + (number-sequence 0 7))))) + +(defun ntlm-compute-timestamp () + "Current time as an NTLMv2 timestamp, as a unibyte string." + (ntlm--time-to-timestamp (time-convert nil 'list))) (defun ntlm-generate-nonce () "Generate a random nonce, not to be used more than once. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index ca43475f453..fae15fe6a8e 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -4781,104 +4781,6 @@ Goes through the list `tramp-inline-compress-commands'." (tramp-message vec 2 "Couldn't find an inline transfer compress command"))))) -;;;###tramp-autoload -(defun tramp-multi-hop-p (vec) - "Whether the method of VEC is capable of multi-hops." - (and (tramp-sh-file-name-handler-p vec) - (not (tramp-get-method-parameter vec 'tramp-copy-program)))) - -(defun tramp-compute-multi-hops (vec) - "Expands VEC according to `tramp-default-proxies-alist'." - (let ((saved-tdpa tramp-default-proxies-alist) - (target-alist `(,vec)) - (hops (or (tramp-file-name-hop vec) "")) - (item vec) - choices proxy) - - ;; Ad-hoc proxy definitions. - (dolist (proxy (reverse (split-string hops tramp-postfix-hop-regexp 'omit))) - (let* ((host-port (tramp-file-name-host-port item)) - (user-domain (tramp-file-name-user-domain item)) - (proxy (concat - tramp-prefix-format proxy tramp-postfix-host-format)) - (entry - (list (and (stringp host-port) - (concat "^" (regexp-quote host-port) "$")) - (and (stringp user-domain) - (concat "^" (regexp-quote user-domain) "$")) - (propertize proxy 'tramp-ad-hoc t)))) - (tramp-message vec 5 "Add %S to `tramp-default-proxies-alist'" entry) - ;; Add the hop. - (add-to-list 'tramp-default-proxies-alist entry) - (setq item (tramp-dissect-file-name proxy)))) - ;; Save the new value. - (when (and hops tramp-save-ad-hoc-proxies) - (customize-save-variable - 'tramp-default-proxies-alist tramp-default-proxies-alist)) - - ;; Look for proxy hosts to be passed. - (setq choices tramp-default-proxies-alist) - (while choices - (setq item (pop choices) - proxy (eval (nth 2 item))) - (when (and - ;; Host. - (string-match-p - (or (eval (nth 0 item)) "") - (or (tramp-file-name-host-port (car target-alist)) "")) - ;; User. - (string-match-p - (or (eval (nth 1 item)) "") - (or (tramp-file-name-user-domain (car target-alist)) ""))) - (if (null proxy) - ;; No more hops needed. - (setq choices nil) - ;; Replace placeholders. - (setq proxy - (format-spec - proxy - (format-spec-make - ?u (or (tramp-file-name-user (car target-alist)) "") - ?h (or (tramp-file-name-host (car target-alist)) "")))) - (with-parsed-tramp-file-name proxy l - ;; Add the hop. - (push l target-alist) - ;; Start next search. - (setq choices tramp-default-proxies-alist))))) - - ;; Foreign and out-of-band methods are not supported for multi-hops. - (when (cdr target-alist) - (setq choices target-alist) - (while (setq item (pop choices)) - (unless (tramp-multi-hop-p item) - (setq tramp-default-proxies-alist saved-tdpa) - (tramp-user-error - vec "Method `%s' is not supported for multi-hops." - (tramp-file-name-method item))))) - - ;; Some methods ("su", "sg", "sudo", "doas", "ksu") do not use the - ;; host name in their command template. In this case, the remote - ;; file name must use either a local host name (first hop), or a - ;; host name matching the previous hop. - (let ((previous-host (or tramp-local-host-regexp ""))) - (setq choices target-alist) - (while (setq item (pop choices)) - (let ((host (tramp-file-name-host item))) - (unless - (or - ;; The host name is used for the remote shell command. - (member - '("%h") (tramp-get-method-parameter item 'tramp-login-args)) - ;; The host name must match previous hop. - (string-match-p previous-host host)) - (setq tramp-default-proxies-alist saved-tdpa) - (tramp-user-error - vec "Host name `%s' does not match `%s'" host previous-host)) - (setq previous-host (concat "^" (regexp-quote host) "$"))))) - - ;; Result. - target-alist)) - (defun tramp-ssh-controlmaster-options (vec) "Return the Control* arguments of the local ssh." (cond diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index ab52bec39eb..83ade66ee14 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -3634,12 +3634,109 @@ User is always nil." (delete-file local-copy))))) t))) +(defun tramp-multi-hop-p (vec) + "Whether the method of VEC is capable of multi-hops." + (and (tramp-sh-file-name-handler-p vec) + (not (tramp-get-method-parameter vec 'tramp-copy-program)))) + +(defun tramp-compute-multi-hops (vec) + "Expands VEC according to `tramp-default-proxies-alist'." + (let ((saved-tdpa tramp-default-proxies-alist) + (target-alist `(,vec)) + (hops (or (tramp-file-name-hop vec) "")) + (item vec) + choices proxy) + + ;; Ad-hoc proxy definitions. + (dolist (proxy (reverse (split-string hops tramp-postfix-hop-regexp 'omit))) + (let* ((host-port (tramp-file-name-host-port item)) + (user-domain (tramp-file-name-user-domain item)) + (proxy (concat + tramp-prefix-format proxy tramp-postfix-host-format)) + (entry + (list (and (stringp host-port) + (concat "^" (regexp-quote host-port) "$")) + (and (stringp user-domain) + (concat "^" (regexp-quote user-domain) "$")) + (propertize proxy 'tramp-ad-hoc t)))) + (tramp-message vec 5 "Add %S to `tramp-default-proxies-alist'" entry) + ;; Add the hop. + (add-to-list 'tramp-default-proxies-alist entry) + (setq item (tramp-dissect-file-name proxy)))) + ;; Save the new value. + (when (and hops tramp-save-ad-hoc-proxies) + (customize-save-variable + 'tramp-default-proxies-alist tramp-default-proxies-alist)) + + ;; Look for proxy hosts to be passed. + (setq choices tramp-default-proxies-alist) + (while choices + (setq item (pop choices) + proxy (eval (nth 2 item))) + (when (and + ;; Host. + (string-match-p + (or (eval (nth 0 item)) "") + (or (tramp-file-name-host-port (car target-alist)) "")) + ;; User. + (string-match-p + (or (eval (nth 1 item)) "") + (or (tramp-file-name-user-domain (car target-alist)) ""))) + (if (null proxy) + ;; No more hops needed. + (setq choices nil) + ;; Replace placeholders. + (setq proxy + (format-spec + proxy + (format-spec-make + ?u (or (tramp-file-name-user (car target-alist)) "") + ?h (or (tramp-file-name-host (car target-alist)) "")))) + (with-parsed-tramp-file-name proxy l + ;; Add the hop. + (push l target-alist) + ;; Start next search. + (setq choices tramp-default-proxies-alist))))) + + ;; Foreign and out-of-band methods are not supported for multi-hops. + (when (cdr target-alist) + (setq choices target-alist) + (while (setq item (pop choices)) + (unless (tramp-multi-hop-p item) + (setq tramp-default-proxies-alist saved-tdpa) + (tramp-user-error + vec "Method `%s' is not supported for multi-hops." + (tramp-file-name-method item))))) + + ;; Some methods ("su", "sg", "sudo", "doas", "ksu") do not use the + ;; host name in their command template. In this case, the remote + ;; file name must use either a local host name (first hop), or a + ;; host name matching the previous hop. + (let ((previous-host (or tramp-local-host-regexp ""))) + (setq choices target-alist) + (while (setq item (pop choices)) + (let ((host (tramp-file-name-host item))) + (unless + (or + ;; The host name is used for the remote shell command. + (member + '("%h") (tramp-get-method-parameter item 'tramp-login-args)) + ;; The host name must match previous hop. + (string-match-p previous-host host)) + (setq tramp-default-proxies-alist saved-tdpa) + (tramp-user-error + vec "Host name `%s' does not match `%s'" host previous-host)) + (setq previous-host (concat "^" (regexp-quote host) "$"))))) + + ;; Result. + target-alist)) + (defun tramp-direct-async-process-p (&rest args) "Whether direct async `make-process' can be called." (let ((v (tramp-dissect-file-name default-directory))) - (and (tramp-get-connection-property v"direct-async-process" nil) - (not (tramp-multi-hop-p v)) - (not (plist-get args :stderr))))) + (and (tramp-get-connection-property v "direct-async-process" nil) + (= (length (tramp-compute-multi-hops v)) 1) + (not (plist-get args :stderr))))) ;; We use BUFFER also as connection buffer during setup. Because of ;; this, its original contents must be saved, and restored once |