diff options
Diffstat (limited to 'lisp/net')
68 files changed, 11764 insertions, 5907 deletions
diff --git a/lisp/net/.gitignore b/lisp/net/.gitignore deleted file mode 100644 index c531d9867f6..00000000000 --- a/lisp/net/.gitignore +++ /dev/null @@ -1 +0,0 @@ -*.elc diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index 177fdaca150..4f7fa3b8f39 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -1,9 +1,10 @@ ;;; ange-ftp.el --- transparent FTP support for GNU Emacs -;; Copyright (C) 1989-1996, 1998, 2000-2013 Free Software Foundation, Inc. +;; Copyright (C) 1989-1996, 1998, 2000-2015 Free Software Foundation, +;; Inc. ;; Author: Andy Norman (ange@hplb.hpl.hp.com) -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: comm ;; This file is part of GNU Emacs. @@ -192,7 +193,7 @@ ;; ;; "^$*$ *" ;; -;; 9) Set the variable ange-ftp-gateway-program-interactive to 't' to let +;; 9) Set the variable ange-ftp-gateway-program-interactive to t to let ;; ange-ftp know that it has to "hand-hold" the login to the gateway ;; machine. ;; @@ -363,7 +364,7 @@ ;; ;; Filename syntax: ;; -;; CMS filenames are entered in a UNIX-y way. In otherwords, minidisks are +;; CMS filenames are entered in a UNIX-y way. In other words, minidisks are ;; treated as UNIX directories. For example to access the file READ.ME in ;; minidisk *.311 on cuvmb.cc.columbia.edu, you would enter ;; /anonymous@cuvmb.cc.columbia.edu:/*.311/READ.ME @@ -680,7 +681,7 @@ '("\\`/\\(\\([^/:]*\\)@\\)?\\([^@/:]*[^@/:.]\\):\\(.*\\)" . (3 2 4)) "Format of a fully expanded remote file name. -This is a list of the form \(REGEXP HOST USER NAME\), +This is a list of the form \(REGEXP HOST USER NAME), where REGEXP is a regular expression matching the full remote name, and HOST, USER, and NAME are the numbers of parenthesized expressions in REGEXP for the components (in that order)." @@ -1106,7 +1107,7 @@ All HOST values should be in lower case.") (defun ange-ftp-message (fmt &rest args) "Display message in echo area, but indicate if truncated. Args are as in `message': a format string, plus arguments to be formatted." - (let ((msg (apply 'format fmt args)) + (let ((msg (apply #'format-message fmt args)) (max (window-width (minibuffer-window)))) (if noninteractive msg @@ -1365,8 +1366,8 @@ only return the directory part of FILE." (goto-char end))) ;; Read in ~/.netrc, if one exists. If ~/.netrc file exists and has -;; the correct permissions then extract the \`machine\', \`login\', -;; \`password\' and \`account\' information from within. +;; the correct permissions then extract the machine, login, +;; password and account information from within. (defun ange-ftp-parse-netrc () ;; We set this before actually doing it to avoid the possibility @@ -1535,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)))) ;;;; ------------------------------------------------------------ @@ -1612,7 +1613,7 @@ good, skip, fatal, or unknown." -6))) (if (zerop ange-ftp-xfer-size) (ange-ftp-message "%s...%dk" ange-ftp-process-msg kbytes) - (let ((percent (/ (* 100 kbytes) ange-ftp-xfer-size))) + (let ((percent (floor (* 100.0 kbytes) ange-ftp-xfer-size))) ;; cut out the redisplay of identical %-age messages. (unless (eq percent ange-ftp-last-percent) (setq ange-ftp-last-percent percent) @@ -2510,7 +2511,7 @@ Works by doing a pwd and examining the directory syntax." ;;;; Remote file and directory listing support. ;;;; ------------------------------------------------------------ -;; Returns whether HOST's FTP server doesn't like \'ls\' or \'dir\' commands +;; Returns whether HOST's FTP server doesn't like 'ls' or 'dir' commands ;; to take switch arguments. (defun ange-ftp-dumb-unix-host (host) (and host ange-ftp-dumb-unix-host-regexp @@ -2830,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) @@ -3655,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) @@ -3733,7 +3742,7 @@ so return the size on the remote host exactly. See RFC 3659." ;; next part of copying routine. (defun ange-ftp-cf1 (result line filename newname binary msg - f-parsed f-host f-user f-name f-abbr + f-parsed f-host f-user _f-name f-abbr t-parsed t-host t-user t-name t-abbr temp1 temp2 cont nowait) (if line @@ -3835,7 +3844,7 @@ so return the size on the remote host exactly. See RFC 3659." (defun ange-ftp-copy-file (filename newname &optional ok-if-already-exists keep-date preserve-uid-gid - preserve-selinux-context) + _preserve-selinux-context) (interactive "fCopy file: \nFCopy %s to file: \np") (ange-ftp-copy-file-internal filename newname @@ -4200,7 +4209,7 @@ directory, so that Emacs will know its current contents." (while (and tryfiles (not copy)) (catch 'ftp-error (let ((ange-ftp-waiting-flag t)) - (condition-case error + (condition-case _error (setq copy (ange-ftp-file-local-copy (car tryfiles))) (ftp-error nil)))) (setq tryfiles (cdr tryfiles))) @@ -4214,7 +4223,7 @@ directory, so that Emacs will know its current contents." (ange-ftp-real-load file noerror nomessage nosuffix))) ;; Calculate default-unhandled-directory for a given ange-ftp buffer. -(defun ange-ftp-unhandled-file-name-directory (filename) +(defun ange-ftp-unhandled-file-name-directory (_filename) nil) @@ -4605,7 +4614,6 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (defun ange-ftp-shell-command (command &optional output-buffer error-buffer) (let* ((parsed (ange-ftp-ftp-name default-directory)) (host (nth 0 parsed)) - (user (nth 1 parsed)) (name (nth 2 parsed))) (if (not parsed) (ange-ftp-real-shell-command command output-buffer error-buffer) @@ -4618,7 +4626,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (format "%s %s \"%s\"" ; remsh -l USER does not work well ; on a hp-ux machine I tried remote-shell-program host command)) - (ange-ftp-message "Remote command '%s' ..." command) + (ange-ftp-message "Remote command `%s' ..." command) ;; Cannot call ange-ftp-real-dired-run-shell-command here as it ;; would prepend "cd default-directory" --- which bombs because ;; default-directory is in ange-ftp syntax for remote file names. @@ -5176,7 +5184,7 @@ Other orders of $ and _ seem to all work just fine.") ;; versions left. If not, then delete the ;; root entry. (maphash - (lambda (key val) + (lambda (key _val) (and (string-match regexp key) (setq versions t))) files) @@ -5358,7 +5366,7 @@ Other orders of $ and _ seem to all work just fine.") ;; compressed files. Instead, we turn "FILE.TYPE" into ;; "FILE.TYPE-Z". Hope that this is a reasonable thing to do. -(defun ange-ftp-vms-make-compressed-filename (name &optional reverse) +(defun ange-ftp-vms-make-compressed-filename (name &optional _reverse) (cond ((string-match "-Z;[0-9]+\\'" name) (list nil (substring name 0 (match-beginning 0)))) @@ -5399,7 +5407,7 @@ Other orders of $ and _ seem to all work just fine.") ;; (cons '(vms . ange-ftp-dired-vms-ls-trim) ;; ange-ftp-dired-ls-trim-alist))) -(defun ange-ftp-vms-sans-version (name &rest args) +(defun ange-ftp-vms-sans-version (name &rest _args) (save-match-data (if (string-match ";[0-9]+\\'" name) (substring name 0 (match-beginning 0)) @@ -5920,7 +5928,7 @@ Other orders of $ and _ seem to all work just fine.") ;; (cons '(cms . ange-ftp-dired-cms-move-to-end-of-filename) ;; ange-ftp-dired-move-to-end-of-filename-alist))) -(defun ange-ftp-cms-make-compressed-filename (name &optional reverse) +(defun ange-ftp-cms-make-compressed-filename (name &optional _reverse) (if (string-match "-Z\\'" name) (list nil (substring name 0 -2)) (list t (concat name "-Z")))) @@ -5970,7 +5978,7 @@ Other orders of $ and _ seem to all work just fine.") (defcustom ange-ftp-bs2000-special-prefix "X" - "Prefix used for filenames starting with '#' or '@'." + "Prefix used for filenames starting with `#' or `@'." :group 'ange-ftp :type 'string) diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 70173dbc0b3..757e368317a 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -1,9 +1,9 @@ ;;; browse-url.el --- pass a URL to a WWW browser -;; Copyright (C) 1995-2013 Free Software Foundation, Inc. +;; Copyright (C) 1995-2015 Free Software Foundation, Inc. ;; Author: Denis Howe <dbh@doc.ic.ac.uk> -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Created: 03 Apr 1995 ;; Keywords: hypertext, hypermedia, mouse @@ -31,89 +31,33 @@ ;; different methods of remote control so there is one function for ;; each supported browser. If the chosen browser is not running, it ;; is started. Currently there is support for the following browsers, -;; some of them probably now obsolete: +;; as well as some other obsolete ones: ;; Function Browser Earliest version ;; browse-url-mozilla Mozilla Don't know ;; browse-url-firefox Firefox Don't know (tried with 1.0.1) ;; browse-url-chromium Chromium 3.0 -;; browse-url-galeon Galeon Don't know ;; browse-url-epiphany Epiphany Don't know -;; browse-url-netscape Netscape 1.1b1 -;; browse-url-mosaic XMosaic/mMosaic <= 2.4 -;; browse-url-cci XMosaic 2.5 +;; browse-url-conkeror Conkeror Don't know ;; browse-url-w3 w3 0 -;; browse-url-w3-gnudoit w3 remotely ;; browse-url-text-* Any text browser 0 ;; browse-url-generic arbitrary ;; browse-url-default-windows-browser MS-Windows browser ;; browse-url-default-macosx-browser Mac OS X browser ;; browse-url-xdg-open Free Desktop xdg-open on Gnome, KDE, Xfce4, LXDE -;; browse-url-gnome-moz GNOME interface to Mozilla ;; browse-url-kde KDE konqueror (kfm) ;; browse-url-elinks Elinks Don't know (tried with 0.12.GIT) -;; [A version of the Netscape browser is now free software -;; <URL:http://www.mozilla.org/>, albeit not GPLed, so it is -;; reasonable to have that as the default.] - -;; Note that versions of Netscape before 1.1b1 did not have remote -;; control. <URL:http://www.netscape.com/newsref/std/x-remote.html>. - ;; Browsers can cache Web pages so it may be necessary to tell them to -;; reload the current page if it has changed (e.g. if you have edited +;; reload the current page if it has changed (e.g., if you have edited ;; it). There is currently no perfect automatic solution to this. -;; Netscape allows you to specify the id of the window you want to -;; control but which window DO you want to control and how do you -;; discover its id? - -;; William M. Perry's excellent "w3" WWW browser for -;; Emacs <URL:ftp://cs.indiana.edu/pub/elisp/w3/> -;; has a function w3-follow-url-at-point, but that -;; doesn't let you edit the URL like browse-url. -;; The `gnuserv' package that can be used to control it in another -;; Emacs process is available from -;; <URL:ftp://ftp.splode.com/pub/users/friedman/packages/>. - -;; Lynx is now distributed by the FSF. See also -;; <URL:http://lynx.browser.org/>. - -;; Free graphical browsers that could be used by `browse-url-generic' -;; include Chimera <URL:ftp://ftp.cs.unlv.edu/pub/chimera> and -;; <URL:http://www.unlv.edu/chimera/>, Arena -;; <URL:ftp://ftp.yggdrasil.com/pub/dist/web/arena> and Amaya -;; <URL:ftp://ftp.w3.org/pub/amaya>. mMosaic -;; <URL:ftp://ftp.enst.fr/pub/mbone/mMosaic/>, -;; <URL:http://www.enst.fr/~dauphin/mMosaic/> (with development -;; support for Java applets and multicast) can be used like Mosaic by -;; setting `browse-url-mosaic-program' appropriately. - -;; I [Denis Howe, not Dave Love] recommend Nelson Minar -;; <nelson@santafe.edu>'s excellent html-helper-mode.el for editing -;; HTML and thank Nelson for his many useful comments on this code. -;; <URL:http://www.santafe.edu/%7Enelson/hhm-beta/> - -;; See also hm--html-menus <URL:http://www.tnt.uni-hannover.de/%7Emuenkel/ -;; software/own/hm--html-menus/>. For composing correct HTML see also -;; PSGML the general SGML structure editor package -;; <URL:ftp://ftp.lysator.liu.se/pub/sgml>; hm--html-menus can be used -;; with this. - ;; This package generalizes function html-previewer-process in Marc ;; Andreessen's html-mode (LCD modes/html-mode.el.Z). See also the ;; ffap.el package. The huge hyperbole package also contains similar ;; functions. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Help! - -;; Can you write and test some code for the Macintrash and Windoze -;; Netscape remote control APIs? (See the URL above). - -;; Do any other browsers have remote control? - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Usage ;; To display the URL at or before point: @@ -169,34 +113,9 @@ ;; To always save modified buffers before displaying the file in a browser: ;; (setq browse-url-save-file t) -;; To get round the Netscape caching problem, you could EITHER have -;; write-file in html-helper-mode make Netscape reload the document: -;; -;; (autoload 'browse-url-netscape-reload "browse-url" -;; "Ask a WWW browser to redisplay the current file." t) -;; (add-hook 'html-helper-mode-hook -;; (lambda () -;; (add-hook 'local-write-file-hooks -;; (lambda () -;; (let ((local-write-file-hooks)) -;; (save-buffer)) -;; (browse-url-netscape-reload) -;; t) ; => file written by hook -;; t))) ; append to l-w-f-hooks -;; -;; OR have browse-url-of-file ask Netscape to load and then reload the -;; file: -;; -;; (add-hook 'browse-url-of-file-hook 'browse-url-netscape-reload) - -;; You may also want to customize browse-url-netscape-arguments, e.g. -;; (setq browse-url-netscape-arguments '("-install")) -;; -;; or similarly for the other browsers. - ;; To invoke different browsers for different URLs: ;; (setq browse-url-browser-function '(("^mailto:" . browse-url-mail) -;; ("." . browse-url-netscape))) +;; ("." . browse-url-firefox))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Code: @@ -225,17 +144,12 @@ function is passed the URL and any other args of `browse-url'. The last regexp should probably be \".\" to specify a default browser." :type '(choice (function-item :tag "Emacs W3" :value browse-url-w3) - (function-item :tag "W3 in another Emacs via `gnudoit'" - :value browse-url-w3-gnudoit) + (function-item :tag "eww" :value eww-browse-url) (function-item :tag "Mozilla" :value browse-url-mozilla) (function-item :tag "Firefox" :value browse-url-firefox) (function-item :tag "Chromium" :value browse-url-chromium) - (function-item :tag "Galeon" :value browse-url-galeon) (function-item :tag "Epiphany" :value browse-url-epiphany) - (function-item :tag "Netscape" :value browse-url-netscape) - (function-item :tag "eww" :value eww-browse-url) - (function-item :tag "Mosaic" :value browse-url-mosaic) - (function-item :tag "Mosaic using CCI" :value browse-url-cci) + (function-item :tag "Conkeror" :value browse-url-conkeror) (function-item :tag "Text browser in an xterm window" :value browse-url-text-xterm) (function-item :tag "Text browser in an Emacs window" @@ -248,8 +162,6 @@ regexp should probably be \".\" to specify a default browser." :value browse-url-default-windows-browser) (function-item :tag "Default Mac OS X browser" :value browse-url-default-macosx-browser) - (function-item :tag "GNOME invoking Mozilla" - :value browse-url-gnome-moz) (function-item :tag "Default browser" :value browse-url-default-browser) (function :tag "Your own function") @@ -282,18 +194,25 @@ system, given vroot.h from the same directory, with cc flags :type 'string :group 'browse-url) +(make-obsolete-variable 'browse-url-netscape-program nil "25.1") + (defcustom browse-url-netscape-arguments nil "A list of strings to pass to Netscape as arguments." :type '(repeat (string :tag "Argument")) :group 'browse-url) +(make-obsolete-variable 'browse-url-netscape-arguments nil "25.1") + (defcustom browse-url-netscape-startup-arguments browse-url-netscape-arguments "A list of strings to pass to Netscape when it starts up. Defaults to the value of `browse-url-netscape-arguments' at the time `browse-url' is loaded." :type '(repeat (string :tag "Argument")) + :group 'browse-url) +(make-obsolete-variable 'browse-url-netscape-startup-arguments nil "25.1") + (defcustom browse-url-browser-display nil "The X display for running the browser, if not same as Emacs's." :type '(choice string (const :tag "Default" nil)) @@ -317,26 +236,29 @@ Defaults to the value of `browse-url-mozilla-arguments' at the time :group 'browse-url) (defcustom browse-url-firefox-program - (let ((candidates '("firefox" "iceweasel" "icecat"))) + (let ((candidates '("icecat" "iceweasel" "firefox"))) (while (and candidates (not (executable-find (car candidates)))) (setq candidates (cdr candidates))) (or (car candidates) "firefox")) - "The name by which to invoke Firefox." + "The name by which to invoke Firefox or a variant of it." :type 'string :group 'browse-url) (defcustom browse-url-firefox-arguments nil - "A list of strings to pass to Firefox as arguments." + "A list of strings to pass to Firefox (or variant) as arguments." :type '(repeat (string :tag "Argument")) :group 'browse-url) (defcustom browse-url-firefox-startup-arguments browse-url-firefox-arguments - "A list of strings to pass to Firefox when it starts up. + "A list of strings to pass to Firefox (or variant) when it starts up. Defaults to the value of `browse-url-firefox-arguments' at the time `browse-url' is loaded." :type '(repeat (string :tag "Argument")) :group 'browse-url) +(make-obsolete-variable 'browse-url-firefox-startup-arguments + "it no longer has any effect." "24.5") + (defcustom browse-url-chromium-program (let ((candidates '("chromium" "chromium-browser"))) (while (and candidates (not (executable-find (car candidates)))) @@ -358,11 +280,15 @@ Defaults to the value of `browse-url-firefox-arguments' at the time :type 'string :group 'browse-url) +(make-obsolete-variable 'browse-url-galeon-program nil "25.1") + (defcustom browse-url-galeon-arguments nil "A list of strings to pass to Galeon as arguments." :type '(repeat (string :tag "Argument")) :group 'browse-url) +(make-obsolete-variable 'browse-url-galeon-arguments nil "25.1") + (defcustom browse-url-galeon-startup-arguments browse-url-galeon-arguments "A list of strings to pass to Galeon when it starts up. Defaults to the value of `browse-url-galeon-arguments' at the time @@ -370,6 +296,8 @@ Defaults to the value of `browse-url-galeon-arguments' at the time :type '(repeat (string :tag "Argument")) :group 'browse-url) +(make-obsolete-variable 'browse-url-galeon-startup-arguments nil "25.1") + (defcustom browse-url-epiphany-program "epiphany" "The name by which to invoke Epiphany." :type 'string @@ -390,12 +318,16 @@ Defaults to the value of `browse-url-epiphany-arguments' at the time ;; GNOME means of invoking either Mozilla or Netscape. (defvar browse-url-gnome-moz-program "gnome-moz-remote") +(make-obsolete-variable 'browse-url-gnome-moz-program nil "25.1") + (defcustom browse-url-gnome-moz-arguments '() "A list of strings passed to the GNOME mozilla viewer as arguments." :version "21.1" :type '(repeat (string :tag "Argument")) :group 'browse-url) +(make-obsolete-variable 'browse-url-gnome-moz-arguments nil "25.1") + (defcustom browse-url-mozilla-new-window-is-tab nil "Whether to open up new windows in a tab or a new window. If non-nil, then open the URL in a new tab rather than a new window if @@ -413,6 +345,13 @@ functionality is not available there." :type 'boolean :group 'browse-url) +(defcustom browse-url-conkeror-new-window-is-buffer nil + "Whether to open up new windows in a buffer or a new window. +If non-nil, then open the URL in a new buffer rather than a new window if +`browse-url-conkeror' is asked to open it in a new window." + :type 'boolean + :group 'browse-url) + (defcustom browse-url-galeon-new-window-is-tab nil "Whether to open up new windows in a tab or a new window. If non-nil, then open the URL in a new tab rather than a new window if @@ -420,6 +359,8 @@ If non-nil, then open the URL in a new tab rather than a new window if :type 'boolean :group 'browse-url) +(make-obsolete-variable 'browse-url-galeon-new-window-is-tab nil "25.1") + (defcustom browse-url-epiphany-new-window-is-tab nil "Whether to open up new windows in a tab or a new window. If non-nil, then open the URL in a new tab rather than a new window if @@ -435,11 +376,12 @@ window." :type 'boolean :group 'browse-url) +(make-obsolete-variable 'browse-url-netscape-new-window-is-tab nil "25.1") + (defcustom browse-url-new-window-flag nil "Non-nil means always open a new browser window with appropriate browsers. Passing an interactive argument to \\[browse-url], or specific browser -commands reverses the effect of this variable. Requires Netscape version -1.1N or later or XMosaic version 2.5 or later if using those browsers." +commands reverses the effect of this variable." :type 'boolean :group 'browse-url) @@ -449,16 +391,33 @@ commands reverses the effect of this variable. Requires Netscape version :version "20.3" :group 'browse-url) +(make-obsolete-variable 'browse-url-mosaic-program nil "25.1") + (defcustom browse-url-mosaic-arguments nil "A list of strings to pass to Mosaic as arguments." :type '(repeat (string :tag "Argument")) :group 'browse-url) +(make-obsolete-variable 'browse-url-mosaic-arguments nil "25.1") + (defcustom browse-url-mosaic-pidfile "~/.mosaicpid" "The name of the pidfile created by Mosaic." :type 'string :group 'browse-url) +(make-obsolete-variable 'browse-url-mosaic-pidfile nil "25.1") + +(defcustom browse-url-conkeror-program "conkeror" + "The name by which to invoke Conkeror." + :type 'string + :version "25.1" + :group 'browse-url) + +(defcustom browse-url-conkeror-arguments nil + "A list of strings to pass to Conkeror as arguments." + :type '(repeat (string :tag "Argument")) + :group 'browse-url) + (defcustom browse-url-filename-alist `(("^/\\(ftp@\\|anonymous@\\)?\\([^:]+\\):/*" . "ftp://\\2/") ;; The above loses the username to avoid the browser prompting for @@ -480,7 +439,7 @@ For example, adding to the default a specific translation of an ange-ftp address to an HTTP URL: (setq browse-url-filename-alist - '((\"/webmaster@webserver:/home/www/html/\" . + \\='((\"/webmaster@webserver:/home/www/html/\" . \"http://www.acme.co.uk/\") (\"^/\\(ftp@\\|anonymous@\\)?\\([^:]+\\):/*\" . \"ftp://\\2/\") (\"^/\\([^:@]+@\\)?\\([^:]+\\):/*\" . \"ftp://\\1\\2/\") @@ -498,12 +457,8 @@ Used by the `browse-url-of-file' command." :group 'browse-url) (defcustom browse-url-of-file-hook nil - "Run after `browse-url-of-file' has asked a browser to load a file. - -Set this to `browse-url-netscape-reload' to force Netscape to load the -file rather than displaying a cached copy." + "Hook run after `browse-url-of-file' has asked a browser to load a file." :type 'hook - :options '(browse-url-netscape-reload) :group 'browse-url) (defcustom browse-url-CCI-port 3003 @@ -513,6 +468,8 @@ the value set in the browser." :type 'integer :group 'browse-url) +(make-obsolete-variable 'browse-url-CCI-port nil "25.1") + (defcustom browse-url-CCI-host "localhost" "Host to access XMosaic via CCI. This should be the host name of the machine running XMosaic with CCI @@ -520,6 +477,8 @@ enabled. The port number should be set in `browse-url-CCI-port'." :type 'string :group 'browse-url) +(make-obsolete-variable 'browse-url-CCI-host nil "25.1") + (defvar browse-url-temp-file-name nil) (make-variable-buffer-local 'browse-url-temp-file-name) @@ -571,6 +530,8 @@ incompatibly at version 4." :type 'number :group 'browse-url) +(make-obsolete-variable 'browse-url-netscape-version nil "25.1") + (defcustom browse-url-text-browser "lynx" "The name of the text browser to invoke." :type 'string @@ -723,9 +684,12 @@ interactively. Turn the filename into a URL with function (defun browse-url-file-url (file) "Return the URL corresponding to FILE. Use variable `browse-url-filename-alist' to map filenames to URLs." - (let ((coding (and (default-value 'enable-multibyte-characters) - (or file-name-coding-system - default-file-name-coding-system)))) + (let ((coding (if (equal system-type 'windows-nt) + ;; W32 pretends that file names are UTF-8 encoded. + 'utf-8 + (and (default-value 'enable-multibyte-characters) + (or file-name-coding-system + default-file-name-coding-system))))) (if coding (setq file (encode-coding-string file coding)))) (setq file (browse-url-url-encode-chars file "[*\"()',=;?% ]")) (dolist (map browse-url-filename-alist) @@ -797,22 +761,25 @@ narrowed." ;;;###autoload (defun browse-url (url &rest args) "Ask a WWW browser to load URL. -Prompts for a URL, defaulting to the URL at or before point. Variable -`browse-url-browser-function' says which browser to use. +Prompt for a URL, defaulting to the URL at or before point. +The variable `browse-url-browser-function' says which browser to use. If the URL is a mailto: URL, consult `browse-url-mailto-function' -first, if that exists." +first, if that exists. + +Passes any ARGS to the browser function. +The default is to pass `browse-url-new-window-flag'." (interactive (browse-url-interactive-arg "URL: ")) (unless (called-interactively-p 'interactive) (setq args (or args (list browse-url-new-window-flag)))) + (when (and url-handler-mode (not (file-name-absolute-p url))) + (setq url (expand-file-name url))) (let ((process-environment (copy-sequence process-environment)) (function (or (and (string-match "\\`mailto:" url) browse-url-mailto-function) browse-url-browser-function)) ;; Ensure that `default-directory' exists and is readable (b#6077). - (default-directory (if (and (file-directory-p default-directory) - (file-readable-p default-directory)) - default-directory - (expand-file-name "~/")))) + (default-directory (or (unhandled-file-name-directory default-directory) + (expand-file-name "~/")))) ;; When connected to various displays, be careful to use the display of ;; the currently selected frame, rather than the original start display, ;; which may not even exist any more. @@ -836,8 +803,9 @@ first, if that exists." ;;;###autoload (defun browse-url-at-point (&optional arg) "Ask a WWW browser to load the URL at or before point. -Doesn't let you edit the URL like `browse-url'. Variable -`browse-url-browser-function' says which browser to use." +Variable `browse-url-browser-function' says which browser to use. +Optional prefix argument ARG non-nil inverts the value of the option +`browse-url-new-window-flag'." (interactive "P") (let ((url (browse-url-url-at-point))) (if url @@ -850,9 +818,8 @@ Doesn't let you edit the URL like `browse-url'. Variable (defun browse-url-at-mouse (event) "Ask a WWW browser to load a URL clicked with the mouse. The URL is the one around or before the position of the mouse click -but point is not changed. Doesn't let you edit the URL like -`browse-url'. Variable `browse-url-browser-function' says which browser -to use." +but point is not changed. Variable `browse-url-browser-function' +says which browser to use." (interactive "e") (save-excursion (mouse-set-point event) @@ -868,7 +835,7 @@ to use." (defvar dos-windows-version) (declare-function w32-shell-execute "w32fns.c") ;; Defined in C. -(defun browse-url-default-windows-browser (url &optional new-window) +(defun browse-url-default-windows-browser (url &optional _new-window) (interactive (browse-url-interactive-arg "URL: ")) (cond ((eq system-type 'ms-dos) (if dos-windows-version @@ -878,7 +845,7 @@ to use." (call-process "cygstart" nil nil nil url)) (t (w32-shell-execute "open" url)))) -(defun browse-url-default-macosx-browser (url &optional new-window) +(defun browse-url-default-macosx-browser (url &optional _new-window) (interactive (browse-url-interactive-arg "URL: ")) (start-process (concat "open " url) nil "open" url)) @@ -922,18 +889,19 @@ used instead of `browse-url-new-window-flag'." ((memq system-type '(darwin)) 'browse-url-default-macosx-browser) ((browse-url-can-use-xdg-open) 'browse-url-xdg-open) - ((executable-find browse-url-gnome-moz-program) 'browse-url-gnome-moz) +;;; ((executable-find browse-url-gnome-moz-program) 'browse-url-gnome-moz) ((executable-find browse-url-mozilla-program) 'browse-url-mozilla) ((executable-find browse-url-firefox-program) 'browse-url-firefox) ((executable-find browse-url-chromium-program) 'browse-url-chromium) - ((executable-find browse-url-galeon-program) 'browse-url-galeon) +;;; ((executable-find browse-url-galeon-program) 'browse-url-galeon) ((executable-find browse-url-kde-program) 'browse-url-kde) - ((executable-find browse-url-netscape-program) 'browse-url-netscape) - ((executable-find browse-url-mosaic-program) 'browse-url-mosaic) +;;; ((executable-find browse-url-netscape-program) 'browse-url-netscape) +;;; ((executable-find browse-url-mosaic-program) 'browse-url-mosaic) + ((executable-find browse-url-conkeror-program) 'browse-url-conkeror) ((executable-find browse-url-xterm-program) 'browse-url-text-xterm) ((locate-library "w3") 'browse-url-w3) (t - (lambda (&rest ignore) (error "No usable browser found")))) + (lambda (&rest _ignore) (error "No usable browser found")))) url args)) (defun browse-url-can-use-xdg-open () @@ -994,6 +962,7 @@ is loaded in a new tab in an existing window instead. When called non-interactively, optional second argument NEW-WINDOW is used instead of `browse-url-new-window-flag'." + (declare (obsolete nil "25.1")) (interactive (browse-url-interactive-arg "URL: ")) (setq url (browse-url-encode-url url)) (let* ((process-environment (browse-url-process-environment)) @@ -1021,6 +990,7 @@ used instead of `browse-url-new-window-flag'." (defun browse-url-netscape-sentinel (process url) "Handle a change to the process communicating with Netscape." + (declare (obsolete nil "25.1")) (or (eq (process-exit-status process) 0) (let* ((process-environment (browse-url-process-environment))) ;; Netscape not running - start it @@ -1032,6 +1002,7 @@ used instead of `browse-url-new-window-flag'." (defun browse-url-netscape-reload () "Ask Netscape to reload its current document. How depends on `browse-url-netscape-version'." + (declare (obsolete nil "25.1")) (interactive) ;; Backwards incompatibility reported by ;; <peter.kruse@psychologie.uni-regensburg.de>. @@ -1041,6 +1012,7 @@ How depends on `browse-url-netscape-version'." (defun browse-url-netscape-send (command) "Send a remote control command to Netscape." + (declare (obsolete nil "25.1")) (let* ((process-environment (browse-url-process-environment))) (apply 'start-process "netscape" nil browse-url-netscape-program @@ -1099,71 +1071,35 @@ used instead of `browse-url-new-window-flag'." ;;;###autoload (defun browse-url-firefox (url &optional new-window) "Ask the Firefox WWW browser to load URL. -Default to the URL around or before point. The strings in -variable `browse-url-firefox-arguments' are also passed to -Firefox. +Defaults to the URL around or before point. Passes the strings +in the variable `browse-url-firefox-arguments' to Firefox. -When called interactively, if variable -`browse-url-new-window-flag' is non-nil, load the document in a -new Firefox window, otherwise use a random existing one. A -non-nil interactive prefix argument reverses the effect of -`browse-url-new-window-flag'. +Interactively, if the variable `browse-url-new-window-flag' is non-nil, +loads the document in a new Firefox window. A non-nil prefix argument +reverses the effect of `browse-url-new-window-flag'. If `browse-url-firefox-new-window-is-tab' is non-nil, then whenever a document would otherwise be loaded in a new window, it is loaded in a new tab in an existing window instead. -When called non-interactively, optional second argument -NEW-WINDOW is used instead of `browse-url-new-window-flag'. - -On MS-Windows systems the optional `new-window' parameter is -ignored. Firefox for Windows does not support the \"-remote\" -command line parameter. Therefore, the -`browse-url-new-window-flag' and `browse-url-firefox-new-window-is-tab' -are ignored as well. Firefox on Windows will always open the requested -URL in a new window." +Non-interactively, this uses the optional second argument NEW-WINDOW +instead of `browse-url-new-window-flag'." (interactive (browse-url-interactive-arg "URL: ")) (setq url (browse-url-encode-url url)) - (let* ((process-environment (browse-url-process-environment)) - (use-remote - (not (memq system-type '(windows-nt ms-dos)))) - (process - (apply 'start-process - (concat "firefox " url) nil - browse-url-firefox-program - (append - browse-url-firefox-arguments - (if use-remote - (list "-remote" - (concat - "openURL(" - url - (if (browse-url-maybe-new-window new-window) - (if browse-url-firefox-new-window-is-tab - ",new-tab" - ",new-window")) - ")")) - (list url)))))) - ;; If we use -remote, the process exits with status code 2 if - ;; Firefox is not already running. The sentinel runs firefox - ;; directly if that happens. - (when use-remote - (set-process-sentinel process - `(lambda (process change) - (browse-url-firefox-sentinel process ,url)))))) - -(defun browse-url-firefox-sentinel (process url) - "Handle a change to the process communicating with Firefox." - (or (eq (process-exit-status process) 0) - (let* ((process-environment (browse-url-process-environment))) - ;; Firefox is not running - start it - (message "Starting Firefox...") - (apply 'start-process (concat "firefox " url) nil - browse-url-firefox-program - (append browse-url-firefox-startup-arguments (list url)))))) + (let* ((process-environment (browse-url-process-environment))) + (apply 'start-process + (concat "firefox " url) nil + browse-url-firefox-program + (append + browse-url-firefox-arguments + (if (browse-url-maybe-new-window new-window) + (if browse-url-firefox-new-window-is-tab + '("-new-tab") + '("-new-window"))) + (list url))))) ;;;###autoload -(defun browse-url-chromium (url &optional new-window) +(defun browse-url-chromium (url &optional _new-window) "Ask the Chromium WWW browser to load URL. Default to the URL around or before point. The strings in variable `browse-url-chromium-arguments' are also passed to @@ -1195,6 +1131,7 @@ new tab in an existing window instead. When called non-interactively, optional second argument NEW-WINDOW is used instead of `browse-url-new-window-flag'." + (declare (obsolete nil "25.1")) (interactive (browse-url-interactive-arg "URL: ")) (setq url (browse-url-encode-url url)) (let* ((process-environment (browse-url-process-environment)) @@ -1216,6 +1153,7 @@ used instead of `browse-url-new-window-flag'." (defun browse-url-galeon-sentinel (process url) "Handle a change to the process communicating with Galeon." + (declare (obsolete nil "25.1")) (or (eq (process-exit-status process) 0) (let* ((process-environment (browse-url-process-environment))) ;; Galeon is not running - start it @@ -1272,7 +1210,7 @@ used instead of `browse-url-new-window-flag'." (defvar url-handler-regexp) ;;;###autoload -(defun browse-url-emacs (url &optional new-window) +(defun browse-url-emacs (url &optional _new-window) "Ask Emacs to load URL into a buffer and show it in another window." (interactive (browse-url-interactive-arg "URL: ")) (require 'url-handlers) @@ -1298,6 +1236,7 @@ effect of `browse-url-new-window-flag'. When called non-interactively, optional second argument NEW-WINDOW is used instead of `browse-url-new-window-flag'." + (declare (obsolete nil "25.1")) (interactive (browse-url-interactive-arg "URL: ")) (apply 'start-process (concat "gnome-moz-remote " url) nil @@ -1326,32 +1265,33 @@ the effect of `browse-url-new-window-flag'. When called non-interactively, optional second argument NEW-WINDOW is used instead of `browse-url-new-window-flag'." + (declare (obsolete nil "25.1")) (interactive (browse-url-interactive-arg "Mosaic URL: ")) (let ((pidfile (expand-file-name browse-url-mosaic-pidfile)) pid) (if (file-readable-p pidfile) - (save-excursion - (find-file pidfile) - (goto-char (point-min)) - (setq pid (read (current-buffer))) - (kill-buffer nil))) - (if (and pid (zerop (signal-process pid 0))) ; Mosaic running - (save-excursion - (find-file (format "/tmp/Mosaic.%d" pid)) - (erase-buffer) - (insert (if (browse-url-maybe-new-window new-window) - "newwin\n" - "goto\n") - url "\n") - (save-buffer) - (kill-buffer nil) + (with-temp-buffer + (insert-file-contents pidfile) + (setq pid (read (current-buffer))))) + (if (and (integerp pid) (zerop (signal-process pid 0))) ; Mosaic running + (progn + (with-temp-buffer + (insert (if (browse-url-maybe-new-window new-window) + "newwin\n" + "goto\n") + url "\n") + (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) ;; Or you could try: ;; (call-process "kill" nil 0 nil "-USR1" (int-to-string pid)) - (message "Signaling Mosaic...done") - ) + (message "Signaling Mosaic...done")) ;; Mosaic not running - start it (message "Starting %s..." browse-url-mosaic-program) (apply 'start-process "xmosaic" nil browse-url-mosaic-program @@ -1376,6 +1316,7 @@ the effect of `browse-url-new-window-flag'. When called non-interactively, optional second argument NEW-WINDOW is used instead of `browse-url-new-window-flag'." + (declare (obsolete nil "25.1")) (interactive (browse-url-interactive-arg "Mosaic URL: ")) (open-network-stream "browse-url" " *browse-url*" browse-url-CCI-host browse-url-CCI-port) @@ -1389,6 +1330,42 @@ used instead of `browse-url-new-window-flag'." (process-send-string "browse-url" "disconnect\r\n") (delete-process "browse-url")) +;; --- Conkeror --- +;;;###autoload +(defun browse-url-conkeror (url &optional new-window) + "Ask the Conkeror WWW browser to load URL. +Default to the URL around or before point. Also pass the strings +in the variable `browse-url-conkeror-arguments' to Conkeror. + +When called interactively, if variable +`browse-url-new-window-flag' is non-nil, load the document in a +new Conkeror window, otherwise use a random existing one. A +non-nil interactive prefix argument reverses the effect of +`browse-url-new-window-flag'. + +If variable `browse-url-conkeror-new-window-is-buffer' is +non-nil, then whenever a document would otherwise be loaded in a +new window, load it in a new buffer in an existing window instead. + +When called non-interactively, use optional second argument +NEW-WINDOW instead of `browse-url-new-window-flag'." + (interactive (browse-url-interactive-arg "URL: ")) + (setq url (browse-url-encode-url url)) + (let* ((process-environment (browse-url-process-environment))) + (apply 'start-process (format "conkeror %s" url) + nil + browse-url-conkeror-program + (append + browse-url-conkeror-arguments + (list + "-e" + (format "load_url_in_new_%s('%s')" + (if (browse-url-maybe-new-window new-window) + (if browse-url-conkeror-new-window-is-buffer + "buffer" + "window") + "buffer") + url)))))) ;; --- W3 --- ;; External. @@ -1413,11 +1390,12 @@ used instead of `browse-url-new-window-flag'." (w3-fetch url))) ;;;###autoload -(defun browse-url-w3-gnudoit (url &optional new-window) +(defun browse-url-w3-gnudoit (url &optional _new-window) ;; new-window ignored "Ask another Emacs running gnuserv to load the URL using the W3 browser. The `browse-url-gnudoit-program' program is used with options given by `browse-url-gnudoit-args'. Default to the URL around or before point." + (declare (obsolete nil "25.1")) (interactive (browse-url-interactive-arg "W3 URL: ")) (apply 'start-process (concat "gnudoit:" url) nil browse-url-gnudoit-program @@ -1428,7 +1406,7 @@ The `browse-url-gnudoit-program' program is used with options given by ;; --- Lynx in an xterm --- ;;;###autoload -(defun browse-url-text-xterm (url &optional new-window) +(defun browse-url-text-xterm (url &optional _new-window) ;; new-window ignored "Ask a text browser to load URL. URL defaults to the URL around or before point. @@ -1469,7 +1447,7 @@ used instead of `browse-url-new-window-flag'." (n browse-url-text-input-attempts)) (require 'term) (if (and (browse-url-maybe-new-window new-buffer) buf) - ;; Rename away the OLD buffer. This isn't very polite, but + ;; Rename away the OLD buffer. This isn't very polite, but ;; term insists on working in a buffer named *lynx* and would ;; choke on *lynx*<1> (progn (set-buffer buf) @@ -1492,7 +1470,7 @@ used instead of `browse-url-new-window-flag'." (get-buffer-process buf) ;; Don't leave around a dead one (especially because of its ;; munged keymap.) - (lambda (process event) + (lambda (process _event) (if (not (memq (process-status process) '(run stop))) (let ((buf (process-buffer process))) (if buf (kill-buffer buf))))))) @@ -1565,7 +1543,7 @@ used instead of `browse-url-new-window-flag'." ;; --- Random browser --- ;;;###autoload -(defun browse-url-generic (url &optional new-window) +(defun browse-url-generic (url &optional _new-window) ;; new-window ignored "Ask the WWW browser defined by `browse-url-generic-program' to load URL. Default to the URL around or before point. A fresh copy of the @@ -1580,7 +1558,7 @@ don't offer a form of remote control." (append browse-url-generic-args (list url)))) ;;;###autoload -(defun browse-url-kde (url &optional new-window) +(defun browse-url-kde (url &optional _new-window) "Ask the KDE WWW browser to load URL. Default to the URL around or before point." (interactive (browse-url-interactive-arg "KDE URL: ")) diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 0e9c4fc5c76..e8e6bc0cb6a 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -1,6 +1,6 @@ ;;; dbus.el --- Elisp bindings for D-Bus. -;; Copyright (C) 2007-2013 Free Software Foundation, Inc. +;; Copyright (C) 2007-2015 Free Software Foundation, Inc. ;; Author: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, hardware @@ -35,7 +35,7 @@ ;; Declare used subroutines and variables. (declare-function dbus-message-internal "dbusbind.c") -(declare-function dbus-init-bus "dbusbind.c") +(declare-function dbus--init-bus "dbusbind.c") (defvar dbus-message-type-invalid) (defvar dbus-message-type-method-call) (defvar dbus-message-type-method-return) @@ -55,6 +55,9 @@ (defconst dbus-path-dbus "/org/freedesktop/DBus" "The object path used to talk to the bus itself.") +(defconst dbus-path-local (concat dbus-path-dbus "/Local") + "The object path used in local/in-process-generated messages.") + ;; Default D-Bus interfaces. (defconst dbus-interface-dbus "org.freedesktop.DBus" @@ -129,6 +132,15 @@ See URL `http://dbus.freedesktop.org/doc/dbus-specification.html#standard-interf ;; </signal> ;; </interface> +(defconst dbus-interface-local (concat dbus-interface-dbus ".Local") + "An interface whose methods can only be invoked by the local implementation.") + +;; <interface name="org.freedesktop.DBus.Local"> +;; <signal name="Disconnected"> +;; <arg name="object_path" type="o"/> +;; </signal> +;; </interface> + ;; Emacs defaults. (defconst dbus-service-emacs "org.gnu.Emacs" "The well known service name of Emacs.") @@ -154,7 +166,7 @@ Otherwise, return result of last form in BODY, or all other errors." (define-obsolete-variable-alias 'dbus-event-error-hooks 'dbus-event-error-functions "24.3") -(defvar dbus-event-error-functions nil +(defvar dbus-event-error-functions '(dbus-notice-synchronous-call-errors) "Functions to be called when a D-Bus error happens in the event handler. Every function must accept two arguments, the event and the error variable caught in `condition-case' by `dbus-error'.") @@ -167,17 +179,34 @@ caught in `condition-case' by `dbus-error'.") A key in this hash table is a list (:serial BUS SERIAL), like in `dbus-registered-objects-table'. BUS is either a Lisp symbol, `:system' or `:session', or a string denoting the bus address. -SERIAL is the serial number of the reply message.") +SERIAL is the serial number of the reply message. + +The value of an entry is a cons (STATE . RESULT). STATE can be +either `:pending' (we are still waiting for the result), +`:complete' (the result is available) or `:error' (the reply +message was an error message).") (defun dbus-call-method-handler (&rest args) "Handler for reply messages of asynchronous D-Bus message calls. It calls the function stored in `dbus-registered-objects-table'. The result will be made available in `dbus-return-values-table'." - (puthash (list :serial - (dbus-event-bus-name last-input-event) - (dbus-event-serial-number last-input-event)) - (if (= (length args) 1) (car args) args) - dbus-return-values-table)) + (let* ((key (list :serial + (dbus-event-bus-name last-input-event) + (dbus-event-serial-number last-input-event))) + (result (gethash key dbus-return-values-table))) + (when (consp result) + (setcar result :complete) + (setcdr result (if (= (length args) 1) (car args) args))))) + +(defun dbus-notice-synchronous-call-errors (ev er) + "Detect errors resulting from pending synchronous calls." + (let* ((key (list :serial + (dbus-event-bus-name ev) + (dbus-event-serial-number ev))) + (result (gethash key dbus-return-values-table))) + (when (consp result) + (setcar result :error) + (setcdr result er)))) (defun dbus-call-method (bus service path interface method &rest args) "Call METHOD on the D-Bus BUS. @@ -248,6 +277,8 @@ object is returned instead of a list containing this single Lisp object. => \"i686\"" + (or (featurep 'dbusbind) + (signal 'dbus-error (list "Emacs not compiled with dbus support"))) (or (memq bus '(:system :session)) (stringp bus) (signal 'wrong-type-argument (list 'keywordp bus))) (or (stringp service) @@ -260,27 +291,44 @@ object is returned instead of a list containing this single Lisp object. (signal 'wrong-type-argument (list 'stringp method))) (let ((timeout (plist-get args :timeout)) + (check-interval 0.001) (key (apply 'dbus-message-internal dbus-message-type-method-call - bus service path interface method 'dbus-call-method-handler args))) + bus service path interface method 'dbus-call-method-handler args)) + (result (cons :pending nil))) ;; Wait until `dbus-call-method-handler' has put the result into ;; `dbus-return-values-table'. If no timeout is given, use the ;; default 25". Events which are not from D-Bus must be restored. ;; `read-event' performs a redisplay. This must be suppressed; it ;; hurts when reading D-Bus events asynchronously. - (with-timeout ((if timeout (/ timeout 1000.0) 25)) - (while (eq (gethash key dbus-return-values-table :ignore) :ignore) - (let ((event (let ((inhibit-redisplay t) unread-command-events) - (read-event nil nil 0.1)))) - (when (and event (not (ignore-errors (dbus-check-event event)))) - (setq unread-command-events - (append unread-command-events (list event))))))) - - ;; Cleanup `dbus-return-values-table'. Return the result. - (prog1 - (gethash key dbus-return-values-table) + + ;; Work around bug#16775 by busy-waiting with gradual backoff for + ;; dbus calls to complete. A better approach would involve either + ;; adding arbitrary wait condition support to read-event or + ;; restructuring dbus as a kind of process object. Poll at most + ;; about once per second for completion. + + (puthash key result dbus-return-values-table) + (unwind-protect + (progn + (with-timeout ((if timeout (/ timeout 1000.0) 25) + (signal 'dbus-error (list "call timed out"))) + (while (eq (car result) :pending) + (let ((event (let ((inhibit-redisplay t) unread-command-events) + (read-event nil nil check-interval)))) + (when event + (if (ignore-errors (dbus-check-event event)) + (setf result (gethash key dbus-return-values-table)) + (setf unread-command-events + (nconc unread-command-events + (cons event nil))))) + (when (< check-interval 1) + (setf check-interval (* check-interval 1.05)))))) + (when (eq (car result) :error) + (signal (cadr result) (cddr result))) + (cdr result)) (remhash key dbus-return-values-table)))) ;; `dbus-call-method' works non-blocking now. @@ -329,13 +377,15 @@ Example: \(dbus-call-method-asynchronously :system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/devices/computer\" - \"org.freedesktop.Hal.Device\" \"GetPropertyString\" 'message + \"org.freedesktop.Hal.Device\" \"GetPropertyString\" \\='message \"system.kernel.machine\") - => \(:serial :system 2) + => (:serial :system 2) -| i686" + (or (featurep 'dbusbind) + (signal 'dbus-error (list "Emacs not compiled with dbus support"))) (or (memq bus '(:system :session)) (stringp bus) (signal 'wrong-type-argument (list 'keywordp bus))) (or (stringp service) @@ -384,6 +434,8 @@ Example: :session nil \"/org/gnu/Emacs\" \"org.gnu.Emacs.FileManager\" \"FileModified\" \"/home/albinus/.emacs\")" + (or (featurep 'dbusbind) + (signal 'dbus-error (list "Emacs not compiled with dbus support"))) (or (memq bus '(:system :session)) (stringp bus) (signal 'wrong-type-argument (list 'keywordp bus))) (or (null service) (stringp service) @@ -402,6 +454,8 @@ Example: "Return for message SERIAL on the D-Bus BUS. This is an internal function, it shall not be used outside dbus.el." + (or (featurep 'dbusbind) + (signal 'dbus-error (list "Emacs not compiled with dbus support"))) (or (memq bus '(:system :session)) (stringp bus) (signal 'wrong-type-argument (list 'keywordp bus))) (or (stringp service) @@ -416,6 +470,8 @@ This is an internal function, it shall not be used outside dbus.el." "Return error message for message SERIAL on the D-Bus BUS. This is an internal function, it shall not be used outside dbus.el." + (or (featurep 'dbusbind) + (signal 'dbus-error (list "Emacs not compiled with dbus support"))) (or (memq bus '(:system :session)) (stringp bus) (signal 'wrong-type-argument (list 'keywordp bus))) (or (stringp service) @@ -488,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" @@ -521,7 +581,7 @@ denoting the bus address. SERVICE must be a known service name. The function returns a keyword, indicating the result of the operation. One of the following keywords is returned: -`:released': Service has become the primary owner of the name. +`:released': We successfully released the service. `:non-existent': Service name does not exist on this bus. @@ -530,12 +590,13 @@ queue of this service." (maphash (lambda (key value) - (dolist (elt value) - (ignore-errors - (when (and (equal bus (cadr key)) (string-equal service (cadr elt))) - (unless - (puthash key (delete elt value) dbus-registered-objects-table) - (remhash key dbus-registered-objects-table)))))) + (unless (equal :serial (car key)) + (dolist (elt value) + (ignore-errors + (when (and (equal bus (cadr key)) (string-equal service (cadr elt))) + (unless + (puthash key (delete elt value) dbus-registered-objects-table) + (remhash key dbus-registered-objects-table))))))) dbus-registered-objects-table) (let ((reply (dbus-call-method bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus @@ -593,10 +654,10 @@ Example: \(dbus-register-signal :system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/Manager\" - \"org.freedesktop.Hal.Manager\" \"DeviceAdded\" 'my-signal-handler) + \"org.freedesktop.Hal.Manager\" \"DeviceAdded\" \\='my-signal-handler) - => \(\(:signal :system \"org.freedesktop.Hal.Manager\" \"DeviceAdded\") - \(\"org.freedesktop.Hal\" \"/org/freedesktop/Hal/Manager\" my-signal-handler)) + => ((:signal :system \"org.freedesktop.Hal.Manager\" \"DeviceAdded\") + (\"org.freedesktop.Hal\" \"/org/freedesktop/Hal/Manager\" my-signal-handler)) `dbus-register-signal' returns an object, which can be used in `dbus-unregister-object' for removing the registration." @@ -646,7 +707,8 @@ Example: (setq counter (match-string 2 (symbol-name key)) args (cdr args) value (car args)) - (unless (and (<= counter 63) (stringp value)) + (unless (and (<= (string-to-number counter) 63) + (stringp value)) (signal 'wrong-type-argument (list "Wrong argument" key value))) (format @@ -751,7 +813,7 @@ discovering the still incomplete interface." "Unregister OBJECT from D-Bus. OBJECT must be the result of a preceding `dbus-register-method', `dbus-register-property' or `dbus-register-signal' call. It -returns `t' if OBJECT has been unregistered, `nil' otherwise. +returns t if OBJECT has been unregistered, nil otherwise. When OBJECT identifies the last method or property, which is registered for the respective service, Emacs releases its @@ -807,7 +869,7 @@ association to the service from D-Bus." ;; Service. (string-equal service (cadr e)) ;; Non-empty object path. - (cl-caddr e) + (nth 2 e) (throw :found t))))) dbus-registered-objects-table) nil)))) @@ -827,10 +889,18 @@ STRING shall be UTF8 coded." (dolist (elt (string-to-list string) (append '(:array) result)) (setq result (append result (list :byte elt))))))) -(defun dbus-byte-array-to-string (byte-array) +(defun dbus-byte-array-to-string (byte-array &optional multibyte) "Transforms BYTE-ARRAY into UTF8 coded string. -BYTE-ARRAY must be a list of structure (c1 c2 ...)." - (apply 'string byte-array)) +BYTE-ARRAY must be a list of structure (c1 c2 ...), or a byte +array as produced by `dbus-string-to-byte-array'. The resulting +string is unibyte encoded, unless MULTIBYTE is non-nil." + (apply + (if multibyte 'string 'unibyte-string) + (if (equal byte-array '(:array :signature "y")) + nil + (let (result) + (dolist (elt byte-array result) + (when (characterp elt) (setq result (append result `(,elt))))))))) (defun dbus-escape-as-identifier (string) "Escape an arbitrary STRING so it follows the rules for a C identifier. @@ -848,7 +918,7 @@ and a smaller allowed set. As a special case, \"\" is escaped to \"_\". Returns the escaped string. Algorithm taken from -telepathy-glib's `tp-escape-as-identifier'." +telepathy-glib's `tp_escape_as_identifier'." (if (zerop (length string)) "_" (replace-regexp-in-string @@ -857,13 +927,13 @@ telepathy-glib's `tp-escape-as-identifier'." string))) (defun dbus-unescape-from-identifier (string) - "Retrieve the original string from the encoded STRING. -STRING must have been coded with `dbus-escape-as-identifier'" + "Retrieve the original string from the encoded STRING as unibyte string. +STRING must have been encoded with `dbus-escape-as-identifier'." (if (string-equal string "_") "" (replace-regexp-in-string "_.." - (lambda (x) (format "%c" (string-to-number (substring x 1) 16))) + (lambda (x) (byte-to-string (string-to-number (substring x 1) 16))) string))) @@ -902,7 +972,8 @@ not well formed." ;; Service. (or (= dbus-message-type-method-return (nth 2 event)) (= dbus-message-type-error (nth 2 event)) - (stringp (nth 4 event))) + (or (stringp (nth 4 event)) + (null (nth 4 event)))) ;; Object path. (or (= dbus-message-type-method-return (nth 2 event)) (= dbus-message-type-error (nth 2 event)) @@ -953,7 +1024,7 @@ If the HANDLER returns a `dbus-error', it is propagated as return message." (nth 1 event) (nth 4 event) (nth 3 event) (cadr err)))) ;; Propagate D-Bus error messages. (run-hook-with-args 'dbus-event-error-functions event err) - (when (or dbus-debug (= dbus-message-type-error (nth 2 event))) + (when dbus-debug (signal (car err) (cdr err)))))) (defun dbus-event-bus-name (event) @@ -1021,7 +1092,7 @@ well formed." (defun dbus-list-activatable-names (&optional bus) "Return the D-Bus service names which can be activated as list. If BUS is left nil, `:system' is assumed. The result is a list -of strings, which is `nil' when there are no activatable service +of strings, which is nil when there are no activatable service names at all." (dbus-ignore-errors (dbus-call-method @@ -1030,7 +1101,7 @@ names at all." (defun dbus-list-names (bus) "Return the service names registered at D-Bus BUS. -The result is a list of strings, which is `nil' when there are no +The result is a list of strings, which is nil when there are no registered service names at all. Well known names are strings like \"org.freedesktop.DBus\". Names starting with \":\" are unique names for services." @@ -1048,7 +1119,7 @@ A service has a known name if it doesn't start with \":\"." (defun dbus-list-queued-owners (bus service) "Return the unique names registered at D-Bus BUS and queued for SERVICE. -The result is a list of strings, or `nil' when there are no +The result is a list of strings, or nil when there are no queued name owners service names at all." (dbus-ignore-errors (dbus-call-method @@ -1057,7 +1128,7 @@ queued name owners service names at all." (defun dbus-get-name-owner (bus service) "Return the name owner of SERVICE registered at D-Bus BUS. -The result is either a string, or `nil' if there is no name owner." +The result is either a string, or nil if there is no name owner." (dbus-ignore-errors (dbus-call-method bus dbus-service-dbus dbus-path-dbus @@ -1072,9 +1143,9 @@ Note, that this autoloads SERVICE if it is not running yet. If it shall be checked whether SERVICE is already running, one shall apply - \(member service \(dbus-list-known-names bus))" + (member service \(dbus-list-known-names bus))" ;; "Ping" raises a D-Bus error if SERVICE does not exist. - ;; Otherwise, it returns silently with `nil'. + ;; Otherwise, it returns silently with nil. (condition-case nil (not (if (natnump timeout) @@ -1085,6 +1156,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. @@ -1248,7 +1335,7 @@ object can contain \"annotation\" children." (defun dbus-introspect-get-annotation-names (bus service path interface &optional name) "Return all annotation names as list of strings. -If NAME is `nil', the annotations are children of INTERFACE, +If NAME is nil, the annotations are children of INTERFACE, otherwise NAME must be a \"method\", \"signal\", or \"property\" object, where the annotations belong to." (let ((object @@ -1265,7 +1352,7 @@ object, where the annotations belong to." (defun dbus-introspect-get-annotation (bus service path interface name annotation) "Return ANNOTATION as XML object. -If NAME is `nil', ANNOTATION is a child of INTERFACE, otherwise +If NAME is nil, ANNOTATION is a child of INTERFACE, otherwise NAME must be the name of a \"method\", \"signal\", or \"property\" object, where the ANNOTATION belongs to." (let ((elt (xml-get-children @@ -1289,7 +1376,7 @@ NAME must be the name of a \"method\", \"signal\", or "Return a list of all argument names as list of strings. NAME must be a \"method\" or \"signal\" object. -Argument names are optional, the function can return `nil' +Argument names are optional, the function can return nil therefore, even if the method or signal has arguments." (let ((object (or (dbus-introspect-get-method bus service path interface name) @@ -1317,9 +1404,9 @@ element of the list returned by `dbus-introspect-get-argument-names'." (bus service path interface name &optional direction) "Return signature of a `method' or `signal', represented by NAME, as string. If NAME is a `method', DIRECTION can be either \"in\" or \"out\". -If DIRECTION is `nil', \"in\" is assumed. +If DIRECTION is nil, \"in\" is assumed. -If NAME is a `signal', and DIRECTION is non-`nil', DIRECTION must +If NAME is a `signal', and DIRECTION is non-nil, DIRECTION must be \"out\"." ;; For methods, we use "in" as default direction. (let ((object (or (dbus-introspect-get-method @@ -1353,7 +1440,7 @@ be \"out\"." (defun dbus-get-property (bus service path interface property) "Return the value of PROPERTY of INTERFACE. It will be checked at BUS, SERVICE, PATH. The result can be any -valid D-Bus value, or `nil' if there is no PROPERTY." +valid D-Bus value, or nil if there is no PROPERTY." (dbus-ignore-errors ;; "Get" returns a variant, so we must use the `car'. (car @@ -1364,7 +1451,7 @@ valid D-Bus value, or `nil' if there is no PROPERTY." (defun dbus-set-property (bus service path interface property value) "Set value of PROPERTY of INTERFACE to VALUE. It will be checked at BUS, SERVICE, PATH. When the value has -been set successful, the result is VALUE. Otherwise, `nil' is +been set successful, the result is VALUE. Otherwise, nil is returned." (dbus-ignore-errors ;; "Set" requires a variant. @@ -1378,7 +1465,7 @@ returned." "Return all properties of INTERFACE at BUS, SERVICE, PATH. The result is a list of entries. Every entry is a cons of the name of the property, and its value. If there are no properties, -`nil' is returned." +nil is returned." (dbus-ignore-errors ;; "GetAll" returns "a{sv}". (let (result) @@ -1544,22 +1631,22 @@ name, and the cdr is the list of properties as returned by \(dbus-get-all-managed-objects :session \"org.gnome.SettingsDaemon\" \"/\") - => \(\(\"/org/gnome/SettingsDaemon/MediaKeys\" - \(\"org.gnome.SettingsDaemon.MediaKeys\") - \(\"org.freedesktop.DBus.Peer\") - \(\"org.freedesktop.DBus.Introspectable\") - \(\"org.freedesktop.DBus.Properties\") - \(\"org.freedesktop.DBus.ObjectManager\")) - \(\"/org/gnome/SettingsDaemon/Power\" - \(\"org.gnome.SettingsDaemon.Power.Keyboard\") - \(\"org.gnome.SettingsDaemon.Power.Screen\") - \(\"org.gnome.SettingsDaemon.Power\" - \(\"Icon\" . \". GThemedIcon battery-full-charged-symbolic \") - \(\"Tooltip\" . \"Laptop battery is charged\")) - \(\"org.freedesktop.DBus.Peer\") - \(\"org.freedesktop.DBus.Introspectable\") - \(\"org.freedesktop.DBus.Properties\") - \(\"org.freedesktop.DBus.ObjectManager\")) + => ((\"/org/gnome/SettingsDaemon/MediaKeys\" + (\"org.gnome.SettingsDaemon.MediaKeys\") + (\"org.freedesktop.DBus.Peer\") + (\"org.freedesktop.DBus.Introspectable\") + (\"org.freedesktop.DBus.Properties\") + (\"org.freedesktop.DBus.ObjectManager\")) + (\"/org/gnome/SettingsDaemon/Power\" + (\"org.gnome.SettingsDaemon.Power.Keyboard\") + (\"org.gnome.SettingsDaemon.Power.Screen\") + (\"org.gnome.SettingsDaemon.Power\" + (\"Icon\" . \". GThemedIcon battery-full-charged-symbolic \") + (\"Tooltip\" . \"Laptop battery is charged\")) + (\"org.freedesktop.DBus.Peer\") + (\"org.freedesktop.DBus.Introspectable\") + (\"org.freedesktop.DBus.Properties\") + (\"org.freedesktop.DBus.ObjectManager\")) ...) If possible, \"org.freedesktop.DBus.ObjectManager.GetManagedObjects\" @@ -1606,10 +1693,9 @@ 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)) - (service (dbus-event-service-name last-input-event)) (path (dbus-event-path-name last-input-event))) ;; "GetManagedObjects" returns "a{oa{sa{sv}}}". (let (interfaces result) @@ -1625,8 +1711,7 @@ It will be registered for all objects created by `dbus-register-method'." ;; Check all registered object paths. (maphash (lambda (key val) - (let ((object (or (nth 2 (car-safe val)) "")) - (interface (nth 2 key))) + (let ((object (or (nth 2 (car-safe val)) ""))) (when (and (equal (butlast key 2) (list :method bus)) (string-prefix-p path object)) (dolist (interface (cons (nth 2 key) interfaces)) @@ -1661,6 +1746,63 @@ It will be registered for all objects created by `dbus-register-method'." result) '(:signature "{oa{sa{sv}}}")))))) +(defun dbus-handle-bus-disconnect () + "React to a bus disconnection. +BUS is the bus that disconnected. This routine unregisters all +handlers on the given bus and causes all synchronous calls +pending at the time of disconnect to fail." + (let ((bus (dbus-event-bus-name last-input-event)) + (keys-to-remove)) + (maphash + (lambda (key value) + (when (and (eq (nth 0 key) :serial) + (eq (nth 1 key) bus)) + (run-hook-with-args + 'dbus-event-error-functions + (list 'dbus-event + bus + dbus-message-type-error + (nth 2 key) + nil + nil + nil + nil + value) + (list 'dbus-error "Bus disconnected" bus)) + (push key keys-to-remove))) + dbus-registered-objects-table) + (dolist (key keys-to-remove) + (remhash key dbus-registered-objects-table)))) + +(defun dbus-init-bus (bus &optional private) + "Establish the connection to D-Bus BUS. + +BUS can be either the symbol `:system' or the symbol `:session', or it +can be a string denoting the address of the corresponding bus. For +the system and session buses, this function is called when loading +`dbus.el', there is no need to call it again. + +The function returns a number, which counts the connections this Emacs +session has established to the BUS under the same unique name (see +`dbus-get-unique-name'). It depends on the libraries Emacs is linked +with, and on the environment Emacs is running. For example, if Emacs +is linked with the gtk toolkit, and it runs in a GTK-aware environment +like Gnome, another connection might already be established. + +When PRIVATE is non-nil, a new connection is established instead of +reusing an existing one. It results in a new unique name at the bus. +This can be used, if it is necessary to distinguish from another +connection used in the same Emacs process, like the one established by +GTK+. It should be used with care for at least the `:system' and +`:session' buses, because other Emacs Lisp packages might already use +this connection to those buses." + (or (featurep 'dbusbind) + (signal 'dbus-error (list "Emacs not compiled with dbus support"))) + (dbus--init-bus bus private) + (dbus-register-signal + bus nil dbus-path-local dbus-interface-local + "Disconnected" #'dbus-handle-bus-disconnect)) + ;; Initialize `:system' and `:session' buses. This adds their file ;; descriptors to input_wait_mask, in order to detect incoming diff --git a/lisp/net/dig.el b/lisp/net/dig.el index 73c2d871824..234139f94bd 100644 --- a/lisp/net/dig.el +++ b/lisp/net/dig.el @@ -1,6 +1,6 @@ ;;; dig.el --- Domain Name System dig interface -;; Copyright (C) 2000-2013 Free Software Foundation, Inc. +;; Copyright (C) 2000-2015 Free Software Foundation, Inc. ;; Author: Simon Josefsson <simon@josefsson.org> ;; Keywords: DNS BIND dig comm diff --git a/lisp/net/dns.el b/lisp/net/dns.el index 1c456eb8202..ba6523f6f5f 100644 --- a/lisp/net/dns.el +++ b/lisp/net/dns.el @@ -1,6 +1,6 @@ ;;; dns.el --- Domain Name Service lookups -;; Copyright (C) 2002-2013 Free Software Foundation, Inc. +;; Copyright (C) 2002-2015 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: network comm @@ -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 106aab2ac0a..e48af4dc205 100644 --- a/lisp/net/eudc-bob.el +++ b/lisp/net/eudc-bob.el @@ -1,9 +1,10 @@ -;;; eudc-bob.el --- Binary Objects Support for EUDC -*- coding: utf-8 -*- +;;; eudc-bob.el --- Binary Objects Support for EUDC -;; Copyright (C) 1999-2013 Free Software Foundation, Inc. +;; 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 8e52a4df4ed..c60911ff0c5 100644 --- a/lisp/net/eudc-export.el +++ b/lisp/net/eudc-export.el @@ -1,9 +1,10 @@ -;;; eudc-export.el --- functions to export EUDC query results -*- coding: utf-8 -*- +;;; eudc-export.el --- functions to export EUDC query results -;; Copyright (C) 1998-2013 Free Software Foundation, Inc. +;; 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 @@ -173,7 +174,7 @@ LOCATION is used as the phone location for BBDB." (condition-case err (setq phone-list (bbdb-parse-phone-number phone)) (error - (if (string= "phone number unparsable." (eudc-cadr err)) + (if (string= "phone number unparsable." (cadr err)) (if (not (y-or-n-p (format "BBDB claims %S to be unparsable--insert anyway? " phone))) (error "Phone number unparsable") (setq phone-list (list (bbdb-string-trim phone)))) diff --git a/lisp/net/eudc-hotlist.el b/lisp/net/eudc-hotlist.el index a8a51b7d61b..55a2fd9a20a 100644 --- a/lisp/net/eudc-hotlist.el +++ b/lisp/net/eudc-hotlist.el @@ -1,9 +1,10 @@ -;;; eudc-hotlist.el --- hotlist management for EUDC -*- coding: utf-8 -*- +;;; eudc-hotlist.el --- hotlist management for EUDC -;; Copyright (C) 1998-2013 Free Software Foundation, Inc. +;; 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 @@ -44,7 +45,7 @@ (define-key map "x" 'kill-this-buffer) map)) -(defun eudc-hotlist-mode () +(define-derived-mode eudc-hotlist-mode fundamental-mode "EUDC-Servers" "Major mode used to edit the hotlist of servers. These are the special commands of this mode: @@ -54,18 +55,12 @@ These are the special commands of this mode: t -- Transpose the server at point and the previous one q -- Commit the changes and quit. x -- Quit without committing the changes." - (interactive) - (kill-all-local-variables) - (setq major-mode 'eudc-hotlist-mode) - (setq mode-name "EUDC-Servers") - (use-local-map eudc-hotlist-mode-map) (when (featurep 'xemacs) (setq mode-popup-menu eudc-hotlist-menu) (when (featurep 'menubar) (set-buffer-menubar current-menubar) (add-submenu nil (cons "EUDC-Hotlist" (cdr (cdr eudc-hotlist-menu)))))) - (setq buffer-read-only t) - (run-mode-hooks 'eudc-hotlist-mode-hook)) + (setq buffer-read-only t)) ;;;###autoload (defun eudc-edit-hotlist () @@ -76,10 +71,8 @@ These are the special commands of this mode: (switch-to-buffer (get-buffer-create "*EUDC Servers*")) (setq buffer-read-only nil) (erase-buffer) - (mapc (function - (lambda (entry) - (setq proto-col (max (length (car entry)) proto-col)))) - eudc-server-hotlist) + (dolist (entry eudc-server-hotlist) + (setq proto-col (max (length (car entry)) proto-col))) (setq proto-col (+ 3 proto-col)) (setq gap (make-string (- proto-col 6) ?\ )) (insert " EUDC Servers\n" @@ -89,17 +82,16 @@ These are the special commands of this mode: "------" gap "--------\n" "\n") (setq eudc-hotlist-list-beginning (point)) - (mapc (lambda (entry) - (insert (car entry)) - (indent-to proto-col) - (insert (symbol-name (cdr entry)) "\n")) - eudc-server-hotlist) - (eudc-hotlist-mode))) + (dolist (entry eudc-server-hotlist) + (insert (car entry)) + (indent-to proto-col) + (insert (symbol-name (cdr entry)) "\n")) + (eudc-hotlist-mode))) (defun eudc-hotlist-add-server () "Add a new server to the list after current one." (interactive) - (if (not (eq major-mode 'eudc-hotlist-mode)) + (if (not (derived-mode-p 'eudc-hotlist-mode)) (error "Not in a EUDC hotlist edit buffer")) (let ((server (read-from-minibuffer "Server: ")) (protocol (completing-read "Protocol: " @@ -117,7 +109,7 @@ These are the special commands of this mode: (defun eudc-hotlist-delete-server () "Delete the server at point from the list." (interactive) - (if (not (eq major-mode 'eudc-hotlist-mode)) + (if (not (derived-mode-p 'eudc-hotlist-mode)) (error "Not in a EUDC hotlist edit buffer")) (let ((buffer-read-only nil)) (save-excursion @@ -130,7 +122,7 @@ These are the special commands of this mode: (defun eudc-hotlist-quit-edit () "Quit the hotlist editing mode and save changes to the hotlist." (interactive) - (if (not (eq major-mode 'eudc-hotlist-mode)) + (if (not (derived-mode-p 'eudc-hotlist-mode)) (error "Not in a EUDC hotlist edit buffer")) (let (hotlist) (goto-char eudc-hotlist-list-beginning) @@ -149,7 +141,7 @@ These are the special commands of this mode: (defun eudc-hotlist-select-server () "Select the server at point as the current server." (interactive) - (if (not (eq major-mode 'eudc-hotlist-mode)) + (if (not (derived-mode-p 'eudc-hotlist-mode)) (error "Not in a EUDC hotlist edit buffer")) (save-excursion (beginning-of-line) @@ -163,7 +155,7 @@ These are the special commands of this mode: (defun eudc-hotlist-transpose-servers () "Swap the order of the server with the previous one in the list." (interactive) - (if (not (eq major-mode 'eudc-hotlist-mode)) + (if (not (derived-mode-p 'eudc-hotlist-mode)) (error "Not in a EUDC hotlist edit buffer")) (let ((buffer-read-only nil)) (save-excursion diff --git a/lisp/net/eudc-vars.el b/lisp/net/eudc-vars.el index d53fd83eee7..8cffa8e466a 100644 --- a/lisp/net/eudc-vars.el +++ b/lisp/net/eudc-vars.el @@ -1,9 +1,10 @@ -;;; eudc-vars.el --- Emacs Unified Directory Client -*- coding: utf-8 -*- +;;; eudc-vars.el --- Emacs Unified Directory Client -;; Copyright (C) 1998-2013 Free Software Foundation, Inc. +;; 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,17 @@ 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" +(defcustom eudc-options-file + (locate-user-emacs-file "eudc-options" ".eudc-options") "A file where the `servers' hotlist is stored." :type '(file :Tag "File Name:") - :group 'eudc) + :version "25.1") (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 +355,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 +389,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 +403,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 ef09267f854..7280d9d2625 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el @@ -1,9 +1,10 @@ -;;; eudc.el --- Emacs Unified Directory Client -*- coding: utf-8 -*- +;;; eudc.el --- Emacs Unified Directory Client -;; Copyright (C) 1998-2013 Free Software Foundation, Inc. +;; 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. @@ -46,6 +47,8 @@ (require 'wid-edit) +(eval-when-compile (require 'cl-lib)) + (eval-and-compile (if (not (fboundp 'make-overlay)) (require 'overlay))) @@ -76,10 +79,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) @@ -108,18 +107,6 @@ ;; attribute name (defvar eudc-protocol-has-default-query-attributes nil) -(defun eudc-cadr (obj) - (car (cdr obj))) - -(defun eudc-cdar (obj) - (cdr (car obj))) - -(defun eudc-caar (obj) - (car (car obj))) - -(defun eudc-cdaar (obj) - (cdr (car (car obj)))) - (defun eudc-plist-member (plist prop) "Return t if PROP has a value specified in PLIST." (if (not (= 0 (% (length plist) 2))) @@ -518,12 +505,12 @@ otherwise they are formatted according to `eudc-user-attribute-names-alist'." precords)) (insert "\n") (widget-create 'push-button - :notify (lambda (&rest ignore) + :notify (lambda (&rest _ignore) (eudc-query-form)) "New query") (widget-insert " ") (widget-create 'push-button - :notify (lambda (&rest ignore) + :notify (lambda (&rest _ignore) (kill-this-buffer)) "Quit") (eudc-mode) @@ -558,10 +545,10 @@ otherwise they are formatted according to `eudc-user-attribute-names-alist'." ;; Search for multiple records (while (and rec - (not (listp (eudc-cdar rec)))) + (not (listp (cdar rec)))) (setq rec (cdr rec))) - (if (null (eudc-cdar rec)) + (if (null (cdar rec)) (list record) ; No duplicate attrs in this record (mapc (function (lambda (field) @@ -593,7 +580,7 @@ otherwise they are formatted according to `eudc-user-attribute-names-alist'." ((eq 'first method) (setq result (eudc-add-field-to-records (cons (car field) - (eudc-cadr field)) + (cadr field)) result))) ((eq 'concat method) (setq result @@ -652,7 +639,7 @@ Each copy is added a new field containing one of the values of FIELD." result)) -(defun eudc-mode () +(define-derived-mode eudc-mode special-mode "EUDC" "Major mode used in buffers displaying the results of directory queries. There is no sense in calling this command from a buffer other than one containing the results of a directory query. @@ -663,15 +650,9 @@ These are the special commands of EUDC mode: n -- Move to next record. p -- Move to previous record. b -- Insert record at point into the BBDB database." - (interactive) - (kill-all-local-variables) - (setq major-mode 'eudc-mode) - (setq mode-name "EUDC") - (use-local-map eudc-mode-map) (if (not (featurep 'xemacs)) (easy-menu-define eudc-emacs-menu eudc-mode-map "" (eudc-menu)) - (setq mode-popup-menu (eudc-menu))) - (run-mode-hooks 'eudc-mode-hook)) + (setq mode-popup-menu (eudc-menu)))) ;;}}} @@ -694,7 +675,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)) @@ -718,7 +700,7 @@ If ERROR is non-nil, report an error if there is none." (let ((result (eudc-query (list (cons 'name name)) '(email))) email) (if (null (cdr result)) - (setq email (eudc-cdaar result)) + (setq email (cl-cdaar result)) (error "Multiple match--use the query form")) (if error (if email @@ -736,7 +718,7 @@ If ERROR is non-nil, report an error if there is none." (let ((result (eudc-query (list (cons 'name name)) '(phone))) phone) (if (null (cdr result)) - (setq phone (eudc-cdaar result)) + (setq phone (cl-cdaar result)) (error "Multiple match--use the query form")) (if error (if phone @@ -772,10 +754,9 @@ 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) + (setq key (caar query-alist) + val (cdar query-alist) cell (assq key query)) (if cell (setcdr cell (concat (cdr cell) " " val)) @@ -818,19 +799,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 @@ -846,24 +837,23 @@ 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 ;; Loop on the servers (while servers - (eudc-set-server (eudc-caar servers) (eudc-cdar servers) t) + (eudc-set-server (caar servers) (cdar servers) t) ;; Determine which formats apply in the query-format list (setq query-formats @@ -893,14 +883,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))) @@ -922,15 +913,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) @@ -995,17 +981,17 @@ queries the server for the existing fields and displays a corresponding form." fields) (widget-insert "\n\n") (widget-create 'push-button - :notify (lambda (&rest ignore) + :notify (lambda (&rest _ignore) (eudc-process-form)) "Query Server") (widget-insert " ") (widget-create 'push-button - :notify (lambda (&rest ignore) + :notify (lambda (&rest _ignore) (eudc-query-form)) "Reset Form") (widget-insert " ") (widget-create 'push-button - :notify (lambda (&rest ignore) + :notify (lambda (&rest _ignore) (kill-this-buffer)) "Quit") (goto-char pt) @@ -1051,14 +1037,14 @@ queries the server for the existing fields and displays a corresponding form." (point)) (setq set-server-p t)) ((and (eq (car sexp) 'setq) - (eq (eudc-cadr sexp) 'eudc-server-hotlist)) + (eq (cadr sexp) 'eudc-server-hotlist)) (delete-region (save-excursion (backward-sexp) (point)) (point)) (setq set-hotlist-p t)) ((and (eq (car sexp) 'provide) - (equal (eudc-cadr sexp) '(quote eudc-options-file))) + (equal (cadr sexp) '(quote eudc-options-file))) (setq provide-p t))) (if (and provide-p set-hotlist-p @@ -1084,7 +1070,7 @@ queries the server for the existing fields and displays a corresponding form." (defun eudc-move-to-next-record () "Move to next record, in a buffer displaying directory query results." (interactive) - (if (not (eq major-mode 'eudc-mode)) + (if (not (derived-mode-p 'eudc-mode)) (error "Not in a EUDC buffer") (let ((pt (next-overlay-change (point)))) (if (< pt (point-max)) @@ -1094,7 +1080,7 @@ queries the server for the existing fields and displays a corresponding form." (defun eudc-move-to-previous-record () "Move to previous record, in a buffer displaying directory query results." (interactive) - (if (not (eq major-mode 'eudc-mode)) + (if (not (derived-mode-p 'eudc-mode)) (error "Not in a EUDC buffer") (let ((pt (previous-overlay-change (point)))) (if (> pt (point-min)) @@ -1122,7 +1108,7 @@ queries the server for the existing fields and displays a corresponding form." (overlay-get (car (overlays-at (point))) 'eudc-record)) :help "Insert record at point into the BBDB database"] ["Insert All Records into BBDB" eudc-batch-export-records-to-bbdb - (and (eq major-mode 'eudc-mode) + (and (derived-mode-p 'eudc-mode) (or (featurep 'bbdb) (prog1 (locate-library "bbdb") (message "")))) :help "Insert all the records returned by a directory query into BBDB"] diff --git a/lisp/net/eudcb-bbdb.el b/lisp/net/eudcb-bbdb.el index d9d2aa5fe85..0545304b4a3 100644 --- a/lisp/net/eudcb-bbdb.el +++ b/lisp/net/eudcb-bbdb.el @@ -1,9 +1,10 @@ -;;; eudcb-bbdb.el --- Emacs Unified Directory Client - BBDB Backend -*- coding: utf-8 -*- +;;; eudcb-bbdb.el --- Emacs Unified Directory Client - BBDB Backend -;; Copyright (C) 1998-2013 Free Software Foundation, Inc. +;; 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,6 +42,24 @@ (defvar eudc-bbdb-current-query nil) (defvar eudc-bbdb-current-return-attributes nil) +(defvar bbdb-version) + +(defun eudc-bbdb-field (field-symbol) + "Convert FIELD-SYMBOL so that it is recognized by the current BBDB version. +BBDB < 3 used `net'; BBDB >= 3 uses `mail'." + ;; This just-in-time translation permits upgrading from BBDB 2 to + ;; BBDB 3 without restarting Emacs. + (if (and (eq field-symbol 'net) + (or + ;; MELPA versions of BBDB may have a bad package version, + ;; but they're all version 3 or later. + (equal bbdb-version "@PACKAGE_VERSION@") + ;; Development versions of BBDB can have the format "X.YZ + ;; devo". Split the string just in case. + (version<= "3" (car (split-string bbdb-version))))) + 'mail + field-symbol)) + (defvar eudc-bbdb-attributes-translation-alist '((name . lastname) (email . net) @@ -84,7 +103,9 @@ (progn (setq bbdb-val (eval (list (intern (concat "bbdb-record-" - (symbol-name attr))) + (symbol-name + (eudc-bbdb-field + attr)))) 'record))) (if (listp bbdb-val) (if eudc-bbdb-enable-substring-matches @@ -167,7 +188,7 @@ The record is filtered according to `eudc-bbdb-current-return-attributes'" (setq val (eval (list (intern (concat "bbdb-record-" - (symbol-name attr))) + (symbol-name (eudc-bbdb-field attr)))) 'record)))) (t (error "Unknown BBDB attribute"))) diff --git a/lisp/net/eudcb-ldap.el b/lisp/net/eudcb-ldap.el index d0ba47ad753..b50d29ddae8 100644 --- a/lisp/net/eudcb-ldap.el +++ b/lisp/net/eudcb-ldap.el @@ -1,9 +1,10 @@ -;;; eudcb-ldap.el --- Emacs Unified Directory Client - LDAP Backend -*- coding: utf-8 -*- +;;; eudcb-ldap.el --- Emacs Unified Directory Client - LDAP Backend -;; Copyright (C) 1998-2013 Free Software Foundation, Inc. +;; 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,14 @@ ("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." + (declare (obsolete eudc-ldap-cleanup-record-filtering-addresses "25.1")) (mapcar (function (lambda (field) - (cons (intern (car field)) + (cons (intern (downcase (car field))) (if (cdr (cdr field)) (cdr field) (car (cdr field)))))) @@ -88,22 +87,36 @@ (defun eudc-filter-$ (string) (mapconcat 'identity (split-string string "\\$") "\n")) -;; Cleanup a LDAP record to make it suitable for EUDC: -;; Make the record a cons-cell instead of a list if it is single-valued -;; Filter the $ character in addresses into \n if not done by the LDAP lib (defun eudc-ldap-cleanup-record-filtering-addresses (record) - (mapcar - (function - (lambda (field) - (let ((name (intern (car field))) + "Clean up RECORD to make it suitable for EUDC. +Make the record a cons-cell instead of a list if it is +single-valued. Change the `$' character in postal addresses to a +newline. Combine separate mail fields into one mail field with +multiple addresses." + (let ((clean-up-addresses (or (not (boundp 'ldap-ignore-attribute-codings)) + (not ldap-ignore-attribute-codings))) + result mail-addresses) + (dolist (field record) + ;; 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. + (let ((name (intern (downcase (car field)))) (value (cdr field))) - (if (memq name '(postaladdress registeredaddress)) - (setq value (mapcar 'eudc-filter-$ value))) - (cons name - (if (cdr value) - value - (car value)))))) - record)) + (when (and clean-up-addresses + (memq name '(postaladdress registeredaddress))) + (setq value (mapcar 'eudc-filter-$ value))) + (if (eq name 'mail) + (setq mail-addresses (append mail-addresses value)) + (push (cons name (if (cdr value) + value + (car value))) + result)))) + (push (cons 'mail (if (cdr mail-addresses) + mail-addresses + (car mail-addresses))) + result) + (nreverse result))) (defun eudc-ldap-simple-query-internal (query &optional return-attrs) "Query the LDAP server with QUERY. @@ -116,11 +129,7 @@ RETURN-ATTRS is a list of attributes to return, defaulting to (if (listp return-attrs) (mapcar 'symbol-name return-attrs)))) final-result) - (if (or (not (boundp 'ldap-ignore-attribute-codings)) - ldap-ignore-attribute-codings) - (setq result - (mapcar 'eudc-ldap-cleanup-record-filtering-addresses result)) - (setq result (mapcar 'eudc-ldap-cleanup-record-simple result))) + (setq result (mapcar 'eudc-ldap-cleanup-record-filtering-addresses result)) (if (and eudc-strict-return-matches return-attrs @@ -136,7 +145,7 @@ RETURN-ATTRS is a list of attributes to return, defaulting to result)) final-result)) -(defun eudc-ldap-get-field-list (dummy &optional objectclass) +(defun eudc-ldap-get-field-list (_dummy &optional objectclass) "Return a list of valid attribute names for the current server. OBJECTCLASS is the LDAP object class for which the valid attribute names are returned. Default to `person'" @@ -146,7 +155,7 @@ attribute names are returned. Default to `person'" (let ((ldap-host-parameters-alist (list (cons eudc-server '(scope subtree sizelimit 1))))) - (mapcar 'eudc-ldap-cleanup-record-simple + (mapcar 'eudc-ldap-cleanup-record-filtering-addresses (ldap-search (eudc-ldap-format-query-as-rfc1558 (list (cons "objectclass" @@ -170,14 +179,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 75b3382f511..a11cd95b05d 100644 --- a/lisp/net/eudcb-mab.el +++ b/lisp/net/eudcb-mab.el @@ -1,9 +1,9 @@ ;;; eudcb-mab.el --- Emacs Unified Directory Client - AddressBook backend -;; Copyright (C) 2003-2013 Free Software Foundation, Inc. +;; Copyright (C) 2003-2015 Free Software Foundation, Inc. ;; Author: John Wiegley <johnw@newartisans.com> -;; Maintainer: FSF +;; 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 1796f2d9806..f144bf695f5 100644 --- a/lisp/net/eudcb-ph.el +++ b/lisp/net/eudcb-ph.el @@ -1,9 +1,10 @@ -;;; eudcb-ph.el --- Emacs Unified Directory Client - CCSO PH/QI Backend -*- coding: utf-8 -*- +;;; eudcb-ph.el --- Emacs Unified Directory Client - CCSO PH/QI Backend -;; Copyright (C) 1998-2013 Free Software Foundation, Inc. +;; 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 @@ -80,7 +81,7 @@ are returned" (eudc-ph-do-request "fields") (if full-records (eudc-ph-parse-query-result) - (mapcar 'eudc-caar (eudc-ph-parse-query-result)))) + (mapcar #'caar (eudc-ph-parse-query-result)))) (defun eudc-ph-parse-query-result (&optional fields) "Return a list of alists of key/values from in `eudc-ph-process-buffer'. @@ -125,9 +126,9 @@ Fields not in FIELDS are discarded." (memq current-key fields)) (if key (setq record (cons (cons key value) record)) ; New key - (setcdr (car record) (if (listp (eudc-cdar record)) - (append (eudc-cdar record) (list value)) - (list (eudc-cdar record) value)))))))) + (setcdr (car record) (if (listp (cdar record)) + (append (cdar record) (list value)) + (list (cdar record) value)))))))) (and (not ignore) (or (null fields) (eq 'all fields) diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 34934a03549..5748e88bbca 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -1,6 +1,6 @@ -;;; eww.el --- Emacs Web Wowser +;;; eww.el --- Emacs Web Wowser -*- lexical-binding:t -*- -;; Copyright (C) 2013 Free Software Foundation, Inc. +;; Copyright (C) 2013-2015 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: html @@ -28,12 +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" - :group 'hypermedia + :version "25.1" + :link '(custom-manual "(eww) Top") + :group 'web :prefix "eww-") (defcustom eww-header-line-format "%t: %u" @@ -45,17 +49,109 @@ :type 'string) (defcustom eww-search-prefix "https://duckduckgo.com/html/?q=" - "Prefix URL to search engine" + "Prefix URL to search engine." :version "24.4" :group 'eww :type 'string) -(defcustom eww-download-path "~/Downloads/" - "Path where files will downloaded." +(defcustom eww-download-directory "~/Downloads/" + "Directory where files will downloaded." :version "24.4" :group 'eww :type 'string) +;;;###autoload +(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." + :version "24.4" + :group 'eww + :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'." + :version "24.4" + :group 'eww + :type '(choice (const "[X]") + (const "☒") ; Unicode BALLOT BOX WITH X + (const "☑") ; Unicode BALLOT BOX WITH CHECK + string)) + +(defcustom eww-form-checkbox-symbol "[ ]" + "Symbol used to represent a checkbox. +See also `eww-form-checkbox-selected-symbol'." + :version "24.4" + :group 'eww + :type '(choice (const "[ ]") + (const "☐") ; Unicode BALLOT BOX + string)) + (defface eww-form-submit '((((type x w32 ns) (class color)) ; Like default mode line :box (:line-width 2 :style released-button) @@ -64,6 +160,14 @@ :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) @@ -88,58 +192,131 @@ :version "24.4" :group 'eww) -(defvar eww-current-url nil) -(defvar eww-current-title "" - "Title of current page.") +(defface eww-form-textarea + '((t (:background "#C0C0C0" + :foreground "black" + :box (:line-width 1)))) + "Face for eww textarea inputs." + :version "24.4" + :group 'eww) + +(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.") + +(defvar eww-link-keymap + (let ((map (copy-keymap shr-map))) + (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: ") - (if (and (= (length (split-string url)) 1) - (> (length (split-string url "\\.")) 1)) - (progn - (unless (string-match-p "\\`[a-zA-Z][-a-zA-Z0-9+.]*://" url) - (setq url (concat "http://" url))) - ;; some site don't redirect final / - (when (string= (url-filename (url-generic-parse-url url)) "") - (setq url (concat url "/")))) - (unless (string-match-p "\\'file:" url) - (setq url (concat eww-search-prefix - (replace-regexp-in-string " " "+" url))))) - (url-retrieve url 'eww-render (list 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 + ;; 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 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)))))) + (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) ;;;###autoload (defun eww-open-file (file) - "Render a file using EWW." + "Render FILE using EWW." (interactive "fFile: ") - (eww (concat "file://" (expand-file-name file)))) + (eww (concat "file://" + (and (memq system-type '(windows-nt ms-dos)) + "/") + (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 BEG and END. +See the `eww-search-prefix' variable for the search engine used." + (interactive "r") + (eww (buffer-substring beg end))) + +(defun eww-html-p (content-type) + "Return non-nil if CONTENT-TYPE designates an HTML content type. +Currently this means either text/html or application/xhtml+xml." + (member content-type '("text/html" + "application/xhtml+xml"))) + +(defun eww-render (status url &optional point buffer encode) (let ((redirect (plist-get status :redirect))) (when redirect (setq url redirect))) - (set (make-local-variable 'eww-next-url) nil) - (set (make-local-variable 'eww-previous-url) nil) - (set (make-local-variable 'eww-up-url) nil) - (set (make-local-variable 'eww-home-url) nil) - (set (make-local-variable 'eww-start-url) nil) - (set (make-local-variable 'eww-contents-url) nil) (let* ((headers (eww-parse-headers)) - (shr-target-id - (and (string-match "#\\(.*\\)" url) - (match-string 1 url))) (content-type (mail-header-parse-content-type (or (cdr (assoc "content-type" headers)) @@ -147,28 +324,32 @@ word(s) will be searched for via `eww-search-prefix'." (charset (intern (downcase (or (cdr (assq 'charset (cdr content-type))) - (eww-detect-charset (equal (car content-type) - "text/html")) - "utf8")))) + (eww-detect-charset (eww-html-p (car content-type))) + "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 (cond - ((equal (car content-type) "text/html") - (eww-display-html charset url)) - ((string-match "^image/" (car content-type)) - (eww-display-image)) + ((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)) + ((eww-html-p (car content-type)) + (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 buffer)) (t - (eww-display-raw charset))) - (setq eww-history-position 0) - (cond - (point - (goto-char point)) - (shr-target-id - (let ((point (next-single-property-change - (point-min) 'shr-target-id))) - (when point - (goto-char (1+ point))))))) + (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 () @@ -197,118 +378,163 @@ word(s) will be searched for via `eww-search-prefix'." "[\t\n\r ]*<\\?xml[\t\n\r ]+[^>]*encoding=\"\\([^\"]+\\)") (match-string 1))))) -(defun eww-display-html (charset url) - (unless (eq charset 'utf8) - (condition-case nil - (decode-coding-region (point) (point-max) charset) - (coding-system-error nil))) +(declare-function libxml-parse-html-region "xml.c" + (start end &optional base-url discard-comments)) + +(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 - (list - 'base (list (cons 'href url)) - (libxml-parse-html-region (point) (point-max))))) - (eww-setup-buffer) - (setq eww-current-url url) - (eww-update-header-line-format) - (let ((inhibit-read-only t) - (after-change-functions nil) - (shr-width nil) - (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)) - (goto-char (point-min)))) - -(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))))) + (or document + (list + 'base (list (cons 'href 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) + (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) - (shr-tag-a cont)) +(defun eww-tag-a (dom) + (eww-handle-link dom) + (let ((start (point))) + (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 - "%" "%%" - (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) - (let* ((start (point)) - (fgcolor (cdr (or (assq :fgcolor cont) - (assq :text cont)))) - (bgcolor (cdr (assq :bgcolor cont))) - (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 (charset) +(defun eww-display-raw (buffer &optional encode) (let ((data (buffer-substring (point) (point-max)))) - (eww-setup-buffer) - (let ((inhibit-read-only t)) - (insert data)) - (goto-char (point-min)))) - -(defun eww-display-image () + (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*")) @@ -318,18 +544,106 @@ word(s) will be searched for via `eww-search-prefix'." (unless (eq major-mode 'eww-mode) (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 (plist-get eww-data :source))) + (with-current-buffer buf + (let ((inhibit-read-only t)) + (delete-region (point-min) (point-max)) + (insert (or source "no source")) + (goto-char (point-min)) + ;; Decode the source and set the buffer's encoding according + ;; to what the HTML source specifies in its 'charset' header, + ;; if any. + (let ((cs (find-auto-coding "" (point-max)))) + (when (consp cs) + (setq cs (car cs)) + (when (coding-system-p cs) + (decode-coding-region (point-min) (point-max) cs) + (setq buffer-file-coding-system last-coding-system-used)))) + (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" 'eww-quit) - (define-key map "g" 'eww-reload) - (define-key map [tab] 'shr-next-link) + (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 "\177" 'scroll-down-command) - (define-key map " " 'scroll-up-command) (define-key map "l" 'eww-back-url) - (define-key map "f" 'eww-forward-url) + (define-key map "r" 'eww-forward-url) (define-key map "n" 'eww-next-url) (define-key map "p" 'eww-previous-url) (define-key map "u" 'eww-up-url) @@ -338,6 +652,12 @@ word(s) will be searched for via `eww-search-prefix'." (define-key map "d" 'eww-download) (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 "F" 'eww-toggle-fonts) (define-key map "b" 'eww-add-bookmark) (define-key map "B" 'eww-list-bookmarks) @@ -345,8 +665,9 @@ word(s) will be searched for via `eww-search-prefix'." (define-key map [(meta p)] 'eww-previous-bookmark) (easy-menu-define nil map "" - '("eww" - ["Quit" eww-quit t] + '("Eww" + ["Exit" quit-window t] + ["Close browser" quit-window t] ["Reload" eww-reload t] ["Back to previous page" eww-back-url :active (not (zerop (length eww-history)))] @@ -354,50 +675,62 @@ word(s) will be searched for via `eww-search-prefix'." :active (not (zerop eww-history-position))] ["Browse with external browser" eww-browse-with-external-browser t] ["Download" eww-download t] + ["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-copy-page-url t] - ["List cookies" url-cookie-list t])) + ["List bookmarks" eww-list-bookmarks t] + ["List cookies" url-cookie-list t] + ["Character Encoding" eww-set-character-encoding])) map)) -(define-derived-mode eww-mode nil "eww" - "Mode for browsing the web. - -\\{eww-mode-map}" - (set (make-local-variable 'eww-current-url) 'author) - (set (make-local-variable 'browse-url-browser-function) 'eww-browse-url) - (set (make-local-variable 'after-change-functions) 'eww-process-text-input) - (set (make-local-variable 'eww-history) nil) - (set (make-local-variable 'eww-history-position) 0) +(defvar eww-tool-bar-map + (let ((map (make-sparse-keymap))) + (dolist (tool-bar-item + '((quit-window . "close") + (eww-reload . "refresh") + (eww-back-url . "left-arrow") + (eww-forward-url . "right-arrow") + (eww-view-source . "show") + (eww-copy-page-url . "copy") + (eww-add-bookmark . "bookmark_add"))) ;; ... + (tool-bar-local-item-from-menu + (car tool-bar-item) (cdr tool-bar-item) map eww-mode-map)) + map) + "Tool bar for `eww-mode'.") + +;; Autoload cookie needed by desktop.el. +;;;###autoload +(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)) + ;; 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) - ) - -(defun eww-save-history () - (push (list :url eww-current-url - :title eww-current-title - :point (point) - :text (buffer-string)) - eww-history)) + (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)) + (cond (new-window + (switch-to-buffer (generate-new-buffer "*eww*")) + (eww-mode))) (eww url)) -(defun eww-quit () - "Exit the Emacs Web Wowser." - (interactive) - (setq eww-history nil) - (kill-buffer (current-buffer))) - (defun eww-back-url () "Go to the previously displayed page." (interactive) (when (>= eww-history-position (length eww-history)) - (error "No previous page")) + (user-error "No previous page")) (eww-save-history) (setq eww-history-position (+ eww-history-position 2)) (eww-restore-history (elt eww-history (1- eww-history-position)))) @@ -406,62 +739,77 @@ word(s) will be searched for via `eww-search-prefix'." "Go to the next displayed page." (interactive) (when (zerop eww-history-position) - (error "No next page")) + (user-error "No next page")) (eww-save-history) (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)) - (goto-char (plist-get elem :point)) - (setq eww-current-url (plist-get elem :url) - eww-current-title (plist-get elem :title)))) + (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)) - (error "No `next' on this page"))) + (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 () "Go to the page marked `previous'. 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)) - (error "No `previous' on this page"))) + (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 () "Go to the page marked `up'. 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)) - (error "No `up' on this page"))) + (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 () "Go to the page marked `top'. 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)) - (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)))) + (eww-browse-url (shr-expand-url best-url (plist-get eww-data :url))) + (user-error "No `top' for this page")))) + +(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. @@ -473,9 +821,15 @@ 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 [space] 'eww-toggle-checkbox) + (define-key map " " 'eww-toggle-checkbox) (define-key map "\r" 'eww-toggle-checkbox) (define-key map [(control c) (control c)] 'eww-submit) map)) @@ -487,8 +841,8 @@ appears in a <link> or <a> tag." (define-key map [(control a)] 'eww-beginning-of-text) (define-key map [(control c) (control c)] 'eww-submit) (define-key map [(control e)] 'eww-end-of-text) - (define-key map [tab] 'shr-next-link) - (define-key map [backtab] 'shr-previous-link) + (define-key map [?\t] 'shr-next-link) + (define-key map [?\M-\t] 'shr-previous-link) map)) (defvar eww-textarea-map @@ -496,8 +850,8 @@ appears in a <link> or <a> tag." (set-keymap-parent map text-mode-map) (define-key map "\r" 'forward-line) (define-key map [(control c) (control c)] 'eww-submit) - (define-key map [tab] 'shr-next-link) - (define-key map [backtab] 'shr-previous-link) + (define-key map [?\t] 'shr-next-link) + (define-key map [?\M-\t] 'shr-previous-link) map)) (defvar eww-select-map @@ -537,13 +891,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") @@ -551,9 +904,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" @@ -564,103 +917,147 @@ 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)) - (insert "[X]") - (insert "[ ]")) + (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")))) + (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) 'local-map eww-text-map) (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)))) + (list :eww-form eww-form + :value value + :type type + :name (dom-attr dom 'name))) (insert " "))) -(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 '("text" "password" "textarea"))) - (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) +(defconst eww-text-input-types '("text" "password" "textarea" + "color" "date" "datetime" "datetime-local" + "email" "month" "number" "search" "tel" + "time" "url" "week") + "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 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) @@ -670,7 +1067,8 @@ appears in a <link> or <a> tag." (when (> pad 0) (insert (make-string pad ? )))) (add-face-text-property (line-beginning-position) - (point) 'eww-form-text) + (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)) @@ -678,21 +1076,22 @@ appears in a <link> or <a> tag." (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))) @@ -704,28 +1103,33 @@ appears in a <link> or <a> tag." (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)) - (dolist (elem cont) - (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))) ""))) + (max 0) + opelem) + (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 (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 @@ -740,6 +1144,8 @@ appears in a <link> or <a> tag." (put-text-property start (point) 'eww-form menu) (add-face-text-property start (point) 'eww-form-select) (put-text-property start (point) 'keymap eww-select-map) + (unless (= start (point)) + (put-text-property start (1+ start) 'help-echo "select field")) (shr-ensure-paragraph)))) (defun eww-select-display (select) @@ -756,7 +1162,6 @@ appears in a <link> or <a> tag." "Change the value of the select drop-down menu under point." (interactive) (let* ((input (get-text-property (point) 'eww-form)) - (properties (text-properties-at (point))) (completion-ignore-case t) (options (delq nil @@ -773,14 +1178,17 @@ appears in a <link> or <a> tag." (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 () @@ -794,9 +1202,9 @@ appears in a <link> or <a> tag." (if (plist-get input :checked) (progn (plist-put input :checked nil) - (eww-update-field "[ ]")) + (eww-update-field eww-form-checkbox-symbol)) (plist-put input :checked t) - (eww-update-field "[X]")))) + (eww-update-field eww-form-checkbox-selected-symbol)))) ;; Radio button. Switch all other buttons off. (let ((name (plist-get input :name))) (save-excursion @@ -806,9 +1214,9 @@ appears in a <link> or <a> tag." (if (not (eq (cdr elem) input)) (progn (plist-put input :checked nil) - (eww-update-field "[ ]")) + (eww-update-field eww-form-checkbox-symbol)) (plist-put input :checked t) - (eww-update-field "[X]"))))) + (eww-update-field eww-form-checkbox-selected-symbol))))) (forward-char 1))))) (defun eww-inputs (form) @@ -825,6 +1233,18 @@ appears in a <link> or <a> tag." (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))) @@ -848,8 +1268,8 @@ appears in a <link> or <a> tag." (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))) @@ -859,6 +1279,16 @@ appears in a <link> or <a> tag." (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 @@ -877,35 +1307,88 @@ appears in a <link> or <a> tag." (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)))))) -(defun eww-browse-with-external-browser () +(defun eww-browse-with-external-browser (&optional url) "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 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 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))) + (cond + ((not url) + (message "No link under point")) + ((string-match "^mailto:" url) + (browse-url-mail url)) + ((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 (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 external))))) + +(defun eww-same-page-p (url1 url2) + "Return non-nil if URL1 and URL2 represent the same page. +Differences in #targets are ignored." + (let ((obj1 (url-generic-parse-url url1)) + (obj2 (url-generic-parse-url url2))) + (setf (url-target obj1) nil) + (setf (url-target obj2) nil) + (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'." @@ -920,8 +1403,10 @@ The browser to used is specified by the `shr-external-browser' variable." (let* ((obj (url-generic-parse-url url)) (path (car (url-path-and-query obj))) (file (eww-make-unique-file-name (file-name-nondirectory path) - eww-download-path))) - (write-file file) + eww-download-directory))) + (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) @@ -930,8 +1415,7 @@ The browser to used is specified by the `shr-external-browser' variable." (setq file "!")) ((string-match "\\`[.]" file) (setq file (concat "!" file)))) - (let ((base file) - (count 1)) + (let ((count 1)) (while (file-exists-p (expand-file-name file directory)) (setq file (if (string-match "\\`\\(.*\\)\\([.][^.]+\\)" file) @@ -941,40 +1425,60 @@ The browser to used is specified by the `shr-external-browser' variable." (setq count (1+ count))) (expand-file-name file directory))) +(defun eww-set-character-encoding (charset) + "Set character encoding to CHARSET. +If CHARSET is nil then use UTF-8." + (interactive "zUse character set (default utf-8): ") + (if (null charset) + (eww-reload nil 'utf-8) + (eww-reload nil charset))) + +(defun eww-toggle-fonts () + "Toggle whether to use monospaced or font-enabled layouts." + (interactive) + (message "Fonts are now %s" + (if (setq shr-use-fonts (not shr-use-fonts)) + "on" + "off")) + (eww-reload)) + ;;; 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)) - (error "Already bookmarked"))) - (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 (equal (plist-get eww-data :url) (plist-get bookmark :url)) + (user-error "Already bookmarked"))) + (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) @@ -983,23 +1487,22 @@ The browser to used is specified by the `shr-external-browser' variable." (defun eww-bookmark-prepare () (eww-read-bookmarks) - (when (null eww-bookmarks) - (error "No bookmarks are defined")) + (unless eww-bookmarks + (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 (truncate-string-to-width title width))) + (insert (format format title (plist-get bookmark :url)) "\n") (put-text-property start (1+ start) 'eww-bookmark bookmark)) (goto-char (point-min)))) @@ -1012,7 +1515,7 @@ The browser to used is specified by the `shr-external-browser' variable." (bookmark (get-text-property start 'eww-bookmark)) (inhibit-read-only t)) (unless bookmark - (error "No bookmark on the current line")) + (user-error "No bookmark on the current line")) (forward-line 1) (push (buffer-substring start (point)) eww-bookmark-kill-ring) (delete-region start (point)) @@ -1023,7 +1526,7 @@ The browser to used is specified by the `shr-external-browser' variable." "Yank a previously killed bookmark to the current line." (interactive) (unless eww-bookmark-kill-ring - (error "No previously killed bookmark")) + (user-error "No previously killed bookmark")) (beginning-of-line) (let ((inhibit-read-only t) (start (point)) @@ -1037,22 +1540,14 @@ The browser to used is specified by the `shr-external-browser' variable." (cons bookmark (nthcdr line eww-bookmarks))))) (eww-write-bookmarks))) -(defun eww-bookmark-quit () - "Kill the current buffer." - (interactive) - (kill-buffer (current-buffer))) - (defun eww-bookmark-browse () "Browse the bookmark under point in eww." (interactive) (let ((bookmark (get-text-property (line-beginning-position) 'eww-bookmark))) (unless bookmark - (error "No bookmark on the current line")) - ;; We wish to leave this window, but if it's the only window here, - ;; just let it remain. - (ignore-errors - (delete-window)) - (eww (plist-get bookmark :url)))) + (user-error "No bookmark on the current line")) + (quit-window) + (eww-browse-url (plist-get bookmark :url)))) (defun eww-next-bookmark () "Go to the next bookmark in the list." @@ -1069,7 +1564,7 @@ The browser to used is specified by the `shr-external-browser' variable." (setq bookmark (get-text-property (line-beginning-position) 'eww-bookmark)) (unless bookmark - (error "No next bookmark"))) + (user-error "No next bookmark"))) (eww-browse-url (plist-get bookmark :url)))) (defun eww-previous-bookmark () @@ -1088,7 +1583,7 @@ The browser to used is specified by the `shr-external-browser' variable." (when (eolp) (forward-line -1)) (if (bobp) - (error "No previous bookmark") + (user-error "No previous bookmark") (forward-line -1)) (setq bookmark (get-text-property (line-beginning-position) 'eww-bookmark))) @@ -1096,20 +1591,323 @@ The browser to used is specified by the `shr-external-browser' variable." (defvar eww-bookmark-mode-map (let ((map (make-sparse-keymap))) - (suppress-keymap map) - (define-key map "q" 'eww-bookmark-quit) (define-key map [(control k)] 'eww-bookmark-kill) (define-key map [(control y)] 'eww-bookmark-yank) (define-key map "\r" 'eww-bookmark-browse) + + (easy-menu-define nil map + "Menu for `eww-bookmark-mode-map'." + '("Eww Bookmark" + ["Exit" quit-window t] + ["Browse" eww-bookmark-browse + :active (get-text-property (line-beginning-position) 'eww-bookmark)] + ["Kill" eww-bookmark-kill + :active (get-text-property (line-beginning-position) 'eww-bookmark)] + ["Yank" eww-bookmark-yank + :active eww-bookmark-kill-ring])) map)) -(define-derived-mode eww-bookmark-mode nil "eww bookmarks" +(define-derived-mode eww-bookmark-mode special-mode "eww bookmarks" "Mode for listing bookmarks. \\{eww-bookmark-mode-map}" (buffer-disable-undo) - (setq buffer-read-only t - truncate-lines t)) + (setq truncate-lines t)) + +;;; History code + +(defun eww-save-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) + (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) + url title format start) + (erase-buffer) + (dolist (history eww-history-trans) + (setq start (point)) + (setq domain-length (max domain-length (length (plist-get history :url)))) + (setq title-length (max title-length (length (plist-get history :title))))) + (setq format (format "%%-%ds %%-%ds" title-length domain-length) + header-line-format + (concat " " (format format "Title" "URL"))) + (dolist (history eww-history-trans) + (setq start (point)) + (setq url (plist-get history :url)) + (setq title (plist-get history :title)) + (insert (format format title url)) + (insert "\n") + (put-text-property start (1+ start) 'eww-history history)) + (goto-char (point-min))) + (pop-to-buffer "*eww history*"))) + +(defun eww-history-browse () + "Browse the history under point in eww." + (interactive) + (let ((history (get-text-property (line-beginning-position) 'eww-history))) + (unless history + (error "No history on the current line")) + (let ((buffer eww-current-buffer)) + (quit-window) + (when buffer + (switch-to-buffer buffer))) + (eww-restore-history history))) + +(defvar eww-history-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\r" 'eww-history-browse) +;; (define-key map "n" 'next-error-no-select) +;; (define-key map "p" 'previous-error-no-select) + + (easy-menu-define nil map + "Menu for `eww-history-mode-map'." + '("Eww History" + ["Exit" quit-window t] + ["Browse" eww-history-browse + :active (get-text-property (line-beginning-position) 'eww-history)])) + map)) + +(define-derived-mode eww-history-mode special-mode "eww history" + "Mode for listing eww-histories. + +\\{eww-history-mode-map}" + (buffer-disable-undo) + (setq 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))) + (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 special-mode "eww buffers" + "Mode for listing buffers. + +\\{eww-buffers-mode-map}" + (buffer-disable-undo) + (setq 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)) + (let ((inhibit-read-only t)) + (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) diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el index 37755806616..479c9a579f3 100644 --- a/lisp/net/gnutls.el +++ b/lisp/net/gnutls.el @@ -1,6 +1,6 @@ ;;; gnutls.el --- Support SSL/TLS connections through GnuTLS -;; Copyright (C) 2010-2013 Free Software Foundation, Inc. +;; Copyright (C) 2010-2015 Free Software Foundation, Inc. ;; Author: Ted Zlatanov <tzz@lifelogs.com> ;; Keywords: comm, tls, ssl, encryption @@ -35,13 +35,13 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) +(require 'cl-lib) (defgroup gnutls nil "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. @@ -51,6 +51,20 @@ set this variable to \"normal:-dhe-rsa\"." :type '(choice (const nil) string)) +(defcustom gnutls-verify-error nil + "If non-nil, this should be a list of checks per hostname regex or t." + :group 'gnutls + :version "24.4" + :type '(choice + (const t) + (repeat :tag "List of hostname regexps with flags for each" + (list + (choice :tag "Hostname" + (const ".*" :tag "Any hostname") + regexp) + (set (const :trustfiles) + (const :hostname)))))) + (defcustom gnutls-trustfiles '( "/etc/ssl/certs/ca-certificates.crt" ; Debian, Ubuntu, Gentoo and Arch Linux @@ -97,9 +111,9 @@ specifying a port number to connect to. Usage example: - \(with-temp-buffer - \(open-gnutls-stream \"tls\" - \(current-buffer) + (with-temp-buffer + (open-gnutls-stream \"tls\" + (current-buffer) \"your server goes here\" \"imaps\")) @@ -115,6 +129,7 @@ trust and key files, and priority string." (declare-function gnutls-boot "gnutls.c" (proc type proplist)) (declare-function gnutls-errorp "gnutls.c" (error)) +(defvar gnutls-log-level) ; gnutls.c (cl-defun gnutls-negotiate (&rest spec @@ -137,19 +152,25 @@ MIN-PRIME-BITS is the minimum acceptable size of Diffie-Hellman keys \(see `gnutls-min-prime-bits' for more information). Use nil for the default. -When VERIFY-HOSTNAME-ERROR is not nil, an error will be raised -when the hostname does not match the presented certificate's host -name. The exact verification algorithm is a basic implementation -of the matching described in RFC2818 (HTTPS), which takes into -account wildcards, and the DNSName/IPAddress subject alternative -name PKIX extension. See GnuTLS' gnutls_x509_crt_check_hostname -for details. When VERIFY-HOSTNAME-ERROR is nil, only a warning -will be issued. +VERIFY-HOSTNAME-ERROR is a backwards compatibility option for +putting `:hostname' in VERIFY-ERROR. + +When VERIFY-ERROR is t or a list containing `:trustfiles', an +error will be raised when the peer certificate verification fails +as per GnuTLS' gnutls_certificate_verify_peers2. Otherwise, only +warnings will be shown about the verification failure. -When VERIFY-ERROR is not nil, an error will be raised when the -peer certificate verification fails as per GnuTLS' -gnutls_certificate_verify_peers2. Otherwise, only warnings will -be shown about the verification failure. +When VERIFY-ERROR is t or a list containing `:hostname', an error +will be raised when the hostname does not match the presented +certificate's host name. The exact verification algorithm is a +basic implementation of the matching described in +RFC2818 (HTTPS), which takes into account wildcards, and the +DNSName/IPAddress subject alternative name PKIX extension. See +GnuTLS' gnutls_x509_crt_check_hostname for details. Otherwise, +only a warning will be issued. + +Note that the list in `gnutls-verify-error', matched against the +HOSTNAME, is the default VERIFY-ERROR. VERIFY-FLAGS is a numeric OR of verification flags only for `gnutls-x509pki' connections. See GnuTLS' x509.h for details; @@ -168,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)) @@ -182,8 +206,30 @@ defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT." (if gnutls-algorithm-priority (upcase gnutls-algorithm-priority) "NORMAL"))))) + (verify-error (or verify-error + ;; this uses the value of `gnutls-verify-error' + (cond + ;; if t, pass it on + ((eq gnutls-verify-error t) + t) + ;; if a list, look for hostname matches + ((listp 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)) - (params `(:priority ,priority-string + params ret) + + (when verify-hostname-error + (push :hostname verify-error)) + + (setq params `(:priority ,priority-string :hostname ,hostname :loglevel ,gnutls-log-level :min-prime-bits ,min-prime-bits @@ -192,9 +238,7 @@ defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT." :keylist ,keylist :verify-flags ,verify-flags :verify-error ,verify-error - :verify-hostname-error ,verify-hostname-error :callbacks nil)) - ret) (gnutls-message-maybe (setq ret (gnutls-boot process type params)) @@ -215,7 +259,7 @@ defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT." (message "%s: (err=[%s] %s) %s" "gnutls.el" doit (gnutls-error-string doit) - (apply 'format format (or params '(nil)))))) + (apply #'format-message format (or params '(nil)))))) (provide 'gnutls) diff --git a/lisp/net/goto-addr.el b/lisp/net/goto-addr.el index 59e4da16619..51d8ed11b0b 100644 --- a/lisp/net/goto-addr.el +++ b/lisp/net/goto-addr.el @@ -1,9 +1,9 @@ ;;; goto-addr.el --- click to browse URL or to send to e-mail address -;; Copyright (C) 1995, 2000-2013 Free Software Foundation, Inc. +;; Copyright (C) 1995, 2000-2015 Free Software Foundation, Inc. ;; Author: Eric Ding <ericding@alum.mit.edu> -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Created: 15 Aug 1995 ;; Keywords: mh-e, www, mouse, mail diff --git a/lisp/net/hmac-def.el b/lisp/net/hmac-def.el index bf80ce153c9..2855fa4d57e 100644 --- a/lisp/net/hmac-def.el +++ b/lisp/net/hmac-def.el @@ -1,6 +1,6 @@ ;;; hmac-def.el --- A macro for defining HMAC functions. -;; Copyright (C) 1999, 2001, 2007-2013 Free Software Foundation, Inc. +;; Copyright (C) 1999, 2001, 2007-2015 Free Software Foundation, Inc. ;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp> ;; Keywords: HMAC, RFC2104 diff --git a/lisp/net/hmac-md5.el b/lisp/net/hmac-md5.el index 3aaa1a8ab31..26f448fee6a 100644 --- a/lisp/net/hmac-md5.el +++ b/lisp/net/hmac-md5.el @@ -1,6 +1,6 @@ ;;; hmac-md5.el --- Compute HMAC-MD5. -;; Copyright (C) 1999, 2001, 2007-2013 Free Software Foundation, Inc. +;; Copyright (C) 1999, 2001, 2007-2015 Free Software Foundation, Inc. ;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp> ;; Keywords: HMAC, RFC2104, HMAC-MD5, MD5, KEYED-MD5, CRAM-MD5 diff --git a/lisp/net/imap.el b/lisp/net/imap.el index 9584ceb24d0..b559ff65908 100644 --- a/lisp/net/imap.el +++ b/lisp/net/imap.el @@ -1,6 +1,6 @@ ;;; imap.el --- imap library -;; Copyright (C) 1998-2013 Free Software Foundation, Inc. +;; Copyright (C) 1998-2015 Free Software Foundation, Inc. ;; Author: Simon Josefsson <simon@josefsson.org> ;; Keywords: mail @@ -139,7 +139,7 @@ (eval-when-compile (require 'cl)) (eval-and-compile ;; For Emacs <22.2 and XEmacs. - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))) + (unless (fboundp 'declare-function) (defmacro declare-function (&rest _r))) (autoload 'starttls-open-stream "starttls") (autoload 'starttls-negotiate "starttls") (autoload 'sasl-find-mechanism "sasl") @@ -661,7 +661,7 @@ sure of changing the value of `foo'." nil))))) done)) -(defun imap-ssl-p (buffer) +(defun imap-ssl-p (_buffer) nil) (defun imap-ssl-open (name buffer server port) @@ -711,7 +711,7 @@ sure of changing the value of `foo'." (message "imap: Opening SSL connection with `%s'...failed" cmd) nil))) -(defun imap-tls-p (buffer) +(defun imap-tls-p (_buffer) nil) (defun imap-tls-open (name buffer server port) @@ -738,7 +738,7 @@ sure of changing the value of `foo'." (when (memq (process-status process) '(open run)) process)))) -(defun imap-network-p (buffer) +(defun imap-network-p (_buffer) t) (defun imap-network-open (name buffer server port) @@ -757,7 +757,7 @@ sure of changing the value of `foo'." (when (memq (process-status process) '(open run)) process)))) -(defun imap-shell-p (buffer) +(defun imap-shell-p (_buffer) nil) (defun imap-shell-open (name buffer server port) @@ -850,15 +850,16 @@ t if it successfully authenticates, nil otherwise." (while (or (not user) (not passwd)) (setq user (or imap-username (read-from-minibuffer - (concat "imap: username for " imap-server - " (using stream `" (symbol-name imap-stream) - "'): ") + (format-message + "imap: username for %s (using stream `%s'): " + imap-server imap-stream) (or user imap-default-user)))) - (setq passwd (or imap-password - (read-passwd - (concat "imap: password for " user "@" - imap-server " (using authenticator `" - (symbol-name imap-auth) "'): ")))) + (setq passwd + (or imap-password + (read-passwd + (format-message + "imap: password for %s@%s (using authenticator `%s'): " + user imap-server imap-auth)))) (when (and user passwd) (if (funcall loginfunc user passwd) (progn @@ -881,10 +882,10 @@ t if it successfully authenticates, nil otherwise." ;; passwd nil)))) ret))) -(defun imap-gssapi-auth-p (buffer) +(defun imap-gssapi-auth-p (_buffer) (eq imap-stream 'gssapi)) -(defun imap-gssapi-auth (buffer) +(defun imap-gssapi-auth (_buffer) (message "imap: Authenticating using GSSAPI...%s" (if (eq imap-stream 'gssapi) "done" "failed")) (eq imap-stream 'gssapi)) @@ -893,7 +894,7 @@ t if it successfully authenticates, nil otherwise." (and (imap-capability 'AUTH=KERBEROS_V4 buffer) (eq imap-stream 'kerberos4))) -(defun imap-kerberos4-auth (buffer) +(defun imap-kerberos4-auth (_buffer) (message "imap: Authenticating using Kerberos 4...%s" (if (eq imap-stream 'kerberos4) "done" "failed")) (eq imap-stream 'kerberos4)) @@ -947,7 +948,7 @@ t if it successfully authenticates, nil otherwise." (imap-quote-specials passwd) "\"")))))) -(defun imap-anonymous-p (buffer) +(defun imap-anonymous-p (_buffer) t) (defun imap-anonymous-auth (buffer) @@ -1838,7 +1839,7 @@ See `imap-enable-exchange-bug-workaround'." (and (imap-fetch-safe '("*" . "*:*") "UID") (list (imap-mailbox-get-1 'uidvalidity mailbox) (apply 'max (imap-message-map - (lambda (uid prop) uid) 'UID)))) + (lambda (uid _prop) uid) 'UID)))) (if old-mailbox (imap-mailbox-select old-mailbox (eq state 'examine)) (imap-mailbox-unselect))))))) @@ -1884,7 +1885,7 @@ first element. The rest of list contains the saved articles' UIDs." (and (imap-fetch-safe '("*" . "*:*") "UID") (list (imap-mailbox-get-1 'uidvalidity mailbox) (apply 'max (imap-message-map - (lambda (uid prop) uid) 'UID)))) + (lambda (uid _prop) uid) 'UID)))) (if old-mailbox (imap-mailbox-select old-mailbox (eq state 'examine)) (imap-mailbox-unselect))))))) @@ -1893,7 +1894,7 @@ first element. The rest of list contains the saved articles' UIDs." (with-current-buffer (or buffer (current-buffer)) (imap-message-appenduid-1 (imap-utf7-encode mailbox)))) -(defun imap-message-append (mailbox article &optional flags date-time buffer) +(defun imap-message-append (mailbox article &optional _flags _date-time buffer) "Append ARTICLE (a buffer) to MAILBOX on server in BUFFER. FLAGS and DATE-TIME is currently not used. Return a cons holding uidvalidity of MAILBOX and UID the newly created article got, or nil diff --git a/lisp/net/ldap.el b/lisp/net/ldap.el index 724904280ef..1c604e330b2 100644 --- a/lisp/net/ldap.el +++ b/lisp/net/ldap.el @@ -1,9 +1,9 @@ ;;; ldap.el --- client interface to LDAP for Emacs -;; Copyright (C) 1998-2013 Free Software Foundation, Inc. +;; Copyright (C) 1998-2015 Free Software Foundation, Inc. ;; Author: Oscar Figueiredo <oscar@cpe.fr> -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Created: April 1998 ;; Keywords: comm @@ -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 @@ -378,9 +376,19 @@ RFC2252 section 4.3.2") (houseidentifier . 15) (supportedalgorithms . 49) (deltarevocationlist . 9) - (dmdname . 15)) + (dmdname . 15) + (carlicense . 15) + (departmentnumber . 15) + (displayname . 15) + (employeenumber . 15) + (employeetype . 15) + (jpegphoto . 28) + (preferredlanguage . 15) + (usersmimecertificate . 5) + (userpkcs12 . 5)) "A map of LDAP attribute names to their type object id minor number. -This table is built from RFC2252 Section 5 and RFC2256 Section 5") +This table is built from RFC2252 Section 5, RFC2256 Section 5 and +RFC2798 Section 9.1.1") ;; Coding/decoding functions @@ -476,6 +484,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. @@ -507,8 +556,8 @@ not their associated values. `auth' is one of the symbols `simple', `krbv41' or `krbv42'. `base' is the base for the search as described in RFC 1779. `scope' is one of the three symbols `sub', `base' or `one'. - `binddn' is the distinguished name of the user to bind as (in RFC 1779 syntax). - `auth' is one of the symbols `simple', `krbv41' or `krbv42' + `binddn' is the distinguished name of the user to bind as (in +RFC 1779 syntax). `passwd' is the password to use for simple authentication. `deref' is one of the symbols `never', `always', `search' or `find'. `timelimit' is the timeout limit for the connection in seconds. @@ -531,7 +580,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 +603,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 +612,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 +634,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 +646,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/mairix.el b/lisp/net/mairix.el index e6a5f8299ac..a73b4dfa921 100644 --- a/lisp/net/mairix.el +++ b/lisp/net/mairix.el @@ -1,6 +1,6 @@ ;;; mairix.el --- Mairix interface for Emacs -;; Copyright (C) 2008-2013 Free Software Foundation, Inc. +;; Copyright (C) 2008-2015 Free Software Foundation, Inc. ;; Author: David Engster <dengste@eml.cc> ;; Keywords: mail searching @@ -116,7 +116,7 @@ You can add further options here if you want to, but better use (defcustom mairix-update-options '("-F" "-Q") "Options when calling mairix for updating the database. -The default is '-F' and '-Q' for making updates faster. You +The default is \"-F\" and \"-Q\" for making updates faster. You should call mairix without these options from time to time (e.g. via cron job)." :type '(repeat string) @@ -124,7 +124,7 @@ time (e.g. via cron job)." (defcustom mairix-search-options '("-Q") "Options when calling mairix for searching. -The default is '-Q' for making searching faster." +The default is \"-Q\" for making searching faster." :type '(repeat string) :group 'mairix) @@ -265,18 +265,22 @@ Currently there are 'threads and 'flags.") (mail-fetch-field field))))) ;;; Gnus -(eval-when-compile - (defvar gnus-article-buffer) - (autoload 'gnus-summary-toggle-header "gnus-sum") - (autoload 'gnus-buffer-exists-p "gnus-util") - (autoload 'message-field-value "message") - (autoload 'gnus-group-read-ephemeral-group "gnus-group") - (autoload 'gnus-alive-p "gnus-util")) + +;; For gnus-buffer-exists-p, although it seems that could be replaced by: +;; (and buffer (get-buffer buffer)) +(eval-when-compile (require 'gnus-util)) +(defvar gnus-article-buffer) +(declare-function gnus-group-read-ephemeral-group "gnus-group" + (group method &optional activate quit-config + request-only select-articles parameters number)) +(declare-function gnus-summary-toggle-header "gnus-sum" (&optional arg)) +(declare-function message-field-value "message" (header &optional not-all)) ;; Display function: (defun mairix-gnus-ephemeral-nndoc (folder) "Create ephemeral nndoc group for reading mbox file FOLDER in Gnus." - (unless (gnus-alive-p) + (unless (and (fboundp 'gnus-alive-p) + (gnus-alive-p)) (error "Gnus is not running")) (gnus-group-read-ephemeral-group ;; add randomness to group string to prevent Gnus from using a @@ -289,26 +293,29 @@ Currently there are 'threads and 'flags.") ;; Fetching mail header field: (defun mairix-gnus-fetch-field (field) "Get mail header FIELD for current message using Gnus." - (unless (gnus-alive-p) + (unless (and (fboundp 'gnus-alive-p) + (gnus-alive-p)) (error "Gnus is not running")) (unless (gnus-buffer-exists-p gnus-article-buffer) (error "No article buffer available")) (with-current-buffer gnus-article-buffer + ;; gnus-art requires gnus-sum and message. (gnus-summary-toggle-header 1) (message-field-value field))) ;;; VM ;;; written by Ulrich Mueller -(eval-when-compile - (autoload 'vm-quit "vm-folder") - (autoload 'vm-visit-folder "vm") - (autoload 'vm-select-folder-buffer "vm-macro") - (autoload 'vm-check-for-killed-summary "vm-misc") - (autoload 'vm-get-header-contents "vm-summary") - (autoload 'vm-check-for-killed-summary "vm-misc") - (autoload 'vm-error-if-folder-empty "vm-misc") - (autoload 'vm-select-marked-or-prefixed-messages "vm-folder")) +(declare-function vm-quit "ext:vm-folder" (&optional no-change)) +(declare-function vm-visit-folder "ext:vm-startup" + (folder &optional read-only)) +(declare-function vm-select-folder-buffer "ext:vm-macro" ()) ; defsubst +(declare-function vm-check-for-killed-summary "ext:vm-misc" ()) +(declare-function vm-error-if-folder-empty "ext:vm-misc" ()) +(declare-function vm-get-header-contents "ext:vm-summary" + (message header-name-regexp &optional clump-sep)) +(declare-function vm-select-marked-or-prefixed-messages "ext:vm-folder" + (prefix)) ;; Display function (defun mairix-vm-display (folder) @@ -391,7 +398,7 @@ Overwrite existing entry? ") (concat "\n\n" (make-string 65 ?=) "\nYou can now customize your saved Mairix searches by modifying\n\ the variable mairix-saved-searches. Don't forget to save your\nchanges \ -in your .emacs by pressing 'Save for Future Sessions'.\n" +in your .emacs by pressing `Save for Future Sessions'.\n" (make-string 65 ?=) "\n"))) (autoload 'mail-strip-quoted-names "mail-utils") @@ -660,7 +667,8 @@ Fill in VALUES if based on an article." " up to N errors(missing/extra/different letters)\n" " ^substring= to match the substring at the beginning of a word.\n")) (widget-insert - "Whitespace will be converted to ',' (i.e. AND). Use '/' for OR.\n\n") + (format-message + "Whitespace will be converted to `,' (i.e. AND). Use `/' for OR.\n\n")) (setq mairix-widgets (mairix-widget-build-editable-fields values)) (when (member 'flags mairix-widget-other) (widget-insert "\nFlags:\n Seen: ") @@ -755,33 +763,26 @@ VALUES may contain values for editable fields from current article." (define-key map [(d)] 'mairix-select-delete) (define-key map [(s)] 'mairix-select-save) map) - "'mairix-searches-mode' keymap.") - -(defvar mairix-searches-mode-font-lock-keywords) - -(defun mairix-searches-mode () + "`mairix-searches-mode' keymap.") + +(defvar mairix-searches-mode-font-lock-keywords + '(("^\\([0-9]+\\)" + (1 font-lock-constant-face)) + ("^[0-9 ]+\\(Name:\\) \\(.*\\)" + (1 font-lock-keyword-face) (2 font-lock-string-face)) + ("^[ ]+\\(Query:\\) \\(.*\\) , " + (1 font-lock-keyword-face) (2 font-lock-string-face)) + (", \\(Threads:\\) \\(.*\\)" + (1 font-lock-keyword-face) (2 font-lock-constant-face)) + ("^\\([A-Z].*\\)$" + (1 font-lock-comment-face)) + ("^[ ]+\\(Folder:\\) \\(.*\\)" + (1 font-lock-keyword-face) (2 font-lock-string-face)))) + +(define-derived-mode mairix-searches-mode fundamental-mode "mairix-searches" "Major mode for editing mairix searches." - (interactive) - (kill-all-local-variables) - (setq major-mode 'mairix-searches-mode) - (setq mode-name "mairix-searches") - (set-syntax-table text-mode-syntax-table) - (use-local-map mairix-searches-mode-map) - (make-local-variable 'font-lock-defaults) - (setq mairix-searches-mode-font-lock-keywords - (list (list "^\\([0-9]+\\)" - '(1 font-lock-constant-face)) - (list "^[0-9 ]+\\(Name:\\) \\(.*\\)" - '(1 font-lock-keyword-face) '(2 font-lock-string-face)) - (list "^[ ]+\\(Query:\\) \\(.*\\) , " - '(1 font-lock-keyword-face) '(2 font-lock-string-face)) - (list ", \\(Threads:\\) \\(.*\\)" - '(1 font-lock-keyword-face) '(2 font-lock-constant-face)) - (list "^\\([A-Z].*\\)$" - '(1 font-lock-comment-face)) - (list "^[ ]+\\(Folder:\\) \\(.*\\)" - '(1 font-lock-keyword-face) '(2 font-lock-string-face)))) - (setq font-lock-defaults '(mairix-searches-mode-font-lock-keywords))) + :syntax-table text-mode-syntax-table + (setq-local font-lock-defaults '(mairix-searches-mode-font-lock-keywords))) (defun mairix-build-search-list () "Display saved searches in current buffer." diff --git a/lisp/net/net-utils.el b/lisp/net/net-utils.el index 810d8963ce2..c6d40b62415 100644 --- a/lisp/net/net-utils.el +++ b/lisp/net/net-utils.el @@ -1,6 +1,6 @@ ;;; net-utils.el --- network functions -;; Copyright (C) 1998-2013 Free Software Foundation, Inc. +;; Copyright (C) 1998-2015 Free Software Foundation, Inc. ;; Author: Peter Breton <pbreton@cs.umb.edu> ;; Created: Sun Mar 16 1997 @@ -204,7 +204,7 @@ This variable is only used if the variable :group 'net-utils :type '(repeat string)) -(defcustom smbclient-prompt-regexp "^smb: \>" +(defcustom smbclient-prompt-regexp "^smb: >" "Regexp which matches the smbclient program's prompt. This variable is only used if the variable @@ -326,9 +326,19 @@ This variable is only used if the variable (insert filtered-string) (set-marker (process-mark process) (point)))))) +(declare-function w32-get-console-output-codepage "w32proc.c" ()) + (defun net-utils-run-program (name header program args) "Run a network information program." - (let ((buf (get-buffer-create (concat "*" name "*")))) + (let ((buf (get-buffer-create (concat "*" name "*"))) + (coding-system-for-read + ;; MS-Windows versions of network utilities output text + ;; encoded in the console (a.k.a. "OEM") codepage, which is + ;; different from the default system (a.k.a. "ANSI") + ;; codepage. + (if (eq system-type 'windows-nt) + (intern (format "cp%d" (w32-get-console-output-codepage))) + coding-system-for-read))) (set-buffer buf) (erase-buffer) (insert header "\n") @@ -352,7 +362,15 @@ This variable is only used if the variable (when proc (set-process-filter proc nil) (delete-process proc))) - (let ((inhibit-read-only t)) + (let ((inhibit-read-only t) + (coding-system-for-read + ;; MS-Windows versions of network utilities output text + ;; encoded in the console (a.k.a. "OEM") codepage, which is + ;; different from the default system (a.k.a. "ANSI") + ;; codepage. + (if (eq system-type 'windows-nt) + (intern (format "cp%d" (w32-get-console-output-codepage))) + coding-system-for-read))) (erase-buffer)) (net-utils-mode) (setq-local net-utils--revert-cmd diff --git a/lisp/net/netrc.el b/lisp/net/netrc.el index b08c052eb71..61da85c7c1c 100644 --- a/lisp/net/netrc.el +++ b/lisp/net/netrc.el @@ -1,5 +1,5 @@ ;;; netrc.el --- .netrc parsing functionality -;; Copyright (C) 1996-2013 Free Software Foundation, Inc. +;; Copyright (C) 1996-2015 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el index ab7d02cc802..1eb5342009c 100644 --- a/lisp/net/network-stream.el +++ b/lisp/net/network-stream.el @@ -1,6 +1,6 @@ ;;; network-stream.el --- open network processes, possibly with encryption -;; Copyright (C) 2010-2013 Free Software Foundation, Inc. +;; Copyright (C) 2010-2015 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: network @@ -45,6 +45,7 @@ (require 'tls) (require 'starttls) (require 'auth-source) +(require 'nsm) (autoload 'gnutls-negotiate "gnutls") (autoload 'open-gnutls-stream "gnutls") @@ -120,7 +121,7 @@ values: :client-certificate should either be a list where the first element is the certificate key file name, and the second - element is the certificate file name itself, or `t', which + element is the certificate file name itself, or t, which means that `auth-source' will be queried for the key and the certificate. This parameter will only be used when doing TLS or STARTTLS connections. @@ -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,18 +235,19 @@ 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 - (if require-tls + (if (or require-tls + (member "--insecure" starttls-extra-arguments)) starttls-extra-arguments ;; For opportunistic TLS upgrades, we don't really ;; care about the identity of the peer. @@ -270,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 @@ -318,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))) @@ -343,29 +354,32 @@ 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)) (when (re-search-forward eoc nil t) (goto-char (match-beginning 0)) (delete-region (point-min) (line-beginning-position)))) - (let* ((capability-command (plist-get parameters :capability-command))) + (let ((capability-command (plist-get parameters :capability-command)) + (eo-capa (or (plist-get parameters :end-of-capability) + eoc))) (list stream (network-stream-get-response stream start eoc) - (network-stream-command stream capability-command eoc) + (network-stream-command stream capability-command eo-capa) 'tls)))))) (defun network-stream-open-shell (name buffer host service parameters) diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el index f017345e8cb..072fd015b60 100644 --- a/lisp/net/newst-backend.el +++ b/lisp/net/newst-backend.el @@ -1,12 +1,11 @@ ;;; newst-backend.el --- Retrieval backend for newsticker. -;; Copyright (C) 2003-2013 Free Software Foundation, Inc. +;; Copyright (C) 2003-2015 Free Software Foundation, Inc. ;; Author: Ulf Jasper <ulf.jasper@web.de> ;; 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'.") @@ -196,7 +193,7 @@ RSS or Atom file. The file is retrieved by calling wget, or whatever you specify as `newsticker-wget-name'. URL may also be a function which returns news data. In this case -`newsticker-retrieval-method' etc. are ignored for this feed. +`newsticker-retrieval-method' etc. are ignored for this feed. The START-TIME can be either a string, or nil. If it is a string it specifies a fixed time at which this feed shall be retrieved for the @@ -238,7 +235,7 @@ which apply for this feed only, overriding the value of 'intern "Method for retrieving news from the web, either `intern' or `extern'. Default value `intern' uses Emacs' built-in asynchronous download -capabilities ('url-retrieve'). If set to `extern' the external +capabilities (`url-retrieve'). If set to `extern' the external program wget is used, see `newsticker-wget-name'." :type '(choice :tag "Method" (const :tag "Intern" intern) @@ -335,9 +332,9 @@ deleted at the next retrieval." This is an alist of the form (FEED-NAME PATTERN-LIST). I.e. each element consists of a FEED-NAME a PATTERN-LIST. Each element of the pattern-list has the form (AGE TITLE-OR-DESCRIPTION REGEXP). -AGE must be one of the symbols 'old or 'immortal. -TITLE-OR-DESCRIPTION must be on of the symbols 'title, -'description, or 'all. REGEXP is a regular expression, i.e. a +AGE must be one of the symbols `old' or `immortal'. +TITLE-OR-DESCRIPTION must be one of the symbols `title', +`description', or `all'. REGEXP is a regular expression, i.e., a string. This filter is checked after a new headline has been retrieved. @@ -346,8 +343,8 @@ pattern-list is checked: The new headline will be marked as AGE if REGEXP matches the headline's TITLE-OR-DESCRIPTION. If, for example, `newsticker-auto-mark-filter-list' looks like - \((slashdot ('old 'title \"^Forget me!$\") ('immortal 'title \"Read me\") - \('immortal 'all \"important\")))) + ((slashdot (\\='old \\='title \"^Forget me!$\") (\\='immortal \\='title \"Read me\") + (\\='immortal \\='all \"important\")))) then all articles from slashdot are marked as old if they have the title \"Forget me!\". All articles with a title containing @@ -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) @@ -573,7 +562,7 @@ If non-nil only the current headline is visible.") "Return guid of ITEM." (newsticker--guid-to-string (assoc 'guid (newsticker--extra item)))) (defsubst newsticker--enclosure (item) - "Return enclosure element of ITEM in the form \(...FIXME...\) or nil." + "Return enclosure element of ITEM in the form (...FIXME...) or nil." (let ((enclosure (assoc 'enclosure (newsticker--extra item)))) (if enclosure (xml-node-attributes enclosure)))) @@ -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 @@ -851,77 +846,30 @@ Argument BUFFER is the buffer of the retrieval process." newsticker--cache name-symbol newsticker--error-headline - (format + (format-message (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 2ba4e5c2716..0cb5d8c6a2f 100644 --- a/lisp/net/newst-plainview.el +++ b/lisp/net/newst-plainview.el @@ -1,11 +1,10 @@ ;;; newst-plainview.el --- Single buffer frontend for newsticker. -;; Copyright (C) 2003-2013 Free Software Foundation, Inc. +;; Copyright (C) 2003-2015 Free Software Foundation, Inc. ;; 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 ;; ====================================================================== @@ -252,7 +251,7 @@ assures that the current feed is completely visible." "List of functions run after the newsticker buffer has been updated. Each function is called after `newsticker-buffer-update' has been called. -The default value '`newsticker-w3m-show-inline-images' loads inline +The default value `\\='newsticker-w3m-show-inline-images' loads inline images." :type 'hook :group 'newsticker-plainview-hooks) @@ -264,7 +263,7 @@ Each function is called after `newsticker-toggle-auto-narrow-to-feed' or `newsticker-toggle-auto-narrow-to-item' has been called. -The default value '`newsticker-w3m-show-inline-images' loads inline +The default value `\\='newsticker-w3m-show-inline-images' loads inline images." :type 'hook :group 'newsticker-plainview-hooks) diff --git a/lisp/net/newst-reader.el b/lisp/net/newst-reader.el index 21bb890f742..105b36e14a3 100644 --- a/lisp/net/newst-reader.el +++ b/lisp/net/newst-reader.el @@ -1,11 +1,10 @@ ;;; newst-reader.el --- Generic RSS reader functions. -;; Copyright (C) 2003-2013 Free Software Foundation, Inc. +;; Copyright (C) 2003-2015 Free Software Foundation, Inc. ;; 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. @@ -101,15 +106,18 @@ window is used when filling. See also `newsticker-justification'." :group 'newsticker-reader) (defcustom newsticker-html-renderer - nil + (if (fboundp 'libxml-parse-html-region) + #'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. Possible functions -are `w3m-region', `w3-region', and `newsticker-htmlr-render'. +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 htmlr if this option is set." :type '(choice :tag "Function" (const :tag "None" nil) + (const :tag "SHR" shr-render-region) (const :tag "w3" w3-region) (const :tag "w3m" w3m-region) (const :tag "htmlr" newsticker-htmlr-render)) @@ -183,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 @@ -206,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) @@ -235,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\). +\(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 1ff231aabfb..9426bb7a8e4 100644 --- a/lisp/net/newst-ticker.el +++ b/lisp/net/newst-ticker.el @@ -1,12 +1,11 @@ ;; newst-ticker.el --- mode line ticker for newsticker. -;; Copyright (C) 2003-2013 Free Software Foundation, Inc. +;; Copyright (C) 2003-2015 Free Software Foundation, Inc. ;; Author: Ulf Jasper <ulf.jasper@web.de> ;; 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 d6c8f6f557d..0c2df8897d7 100644 --- a/lisp/net/newst-treeview.el +++ b/lisp/net/newst-treeview.el @@ -1,10 +1,9 @@ -;;; newst-treeview.el --- Treeview frontend for newsticker. +;;; newst-treeview.el --- Treeview frontend for newsticker. -*- lexical-binding:t -*- -;; Copyright (C) 2008-2013 Free Software Foundation, Inc. +;; Copyright (C) 2008-2015 Free Software Foundation, Inc. ;; Author: Ulf Jasper <ulf.jasper@web.de> ;; Filename: newst-treeview.el -;; URL: http://www.nongnu.org/newsticker ;; Created: 2007 ;; Keywords: News, RSS, Atom ;; Package: newsticker @@ -83,6 +82,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 +131,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") @@ -210,7 +218,7 @@ their id stays constant." ;;(message "%s/%s %s/%s" (widget-get node1 :tag) (widget-get node2 :tag) ;; (or id1 -1) (or id2 -1)) (or (newsticker--treeview-ids-eq id1 id2) - (string= (widget-get node1 :tag) (widget-get node2 :tag))))) + (string= (widget-get node1 :nt-feed) (widget-get node2 :nt-feed))))) (defun newsticker--treeview-do-get-node-of-feed (feed-name startnode) "Recursively search node for feed FEED-NAME starting from STARTNODE." @@ -230,28 +238,30 @@ 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)) ;; ====================================================================== -(unless (fboundp 'declare-function) (defmacro declare-function (&rest r))) +(unless (fboundp 'declare-function) (defmacro declare-function (&rest _))) (declare-function w3m-toggle-inline-images "ext:w3m" (&optional force no-cache)) +(defvar w3m-fill-column) +(defvar w3-maximum-line-length) (defun newsticker--treeview-render-text (start end) "Render text between markers START and END." @@ -307,7 +317,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 +329,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) @@ -341,7 +352,7 @@ If string SHOW-FEED is non-nil it is shown in the item string." (remove-overlays)))) (defun newsticker--treeview-list-items-with-age-callback (widget - changed-widget + _changed-widget &rest ages) "Fill newsticker treeview list window with items of certain age. This is a callback function for the treeview nodes. @@ -350,7 +361,7 @@ Argument CHANGED-WIDGET is the widget that actually has changed. Optional argument AGES is the list of ages that are to be shown." (newsticker--treeview-list-clear) (widget-put widget :nt-selected t) - (apply 'newsticker--treeview-list-items-with-age ages)) + (apply #'newsticker--treeview-list-items-with-age ages)) (defun newsticker--treeview-list-items-with-age (&rest ages) "Actually fill newsticker treeview list window with items of certain age. @@ -367,7 +378,7 @@ AGES is the list of ages that are to be shown." (newsticker--treeview-list-update nil)) (defun newsticker--treeview-list-new-items (widget changed-widget - &optional event) + &optional _event) "Fill newsticker treeview list window with new items. This is a callback function for the treeview nodes. Argument WIDGET is the calling treeview widget. @@ -380,7 +391,7 @@ Optional argument EVENT is the mouse event that triggered this action." "This is a virtual feed containing all new items")) (defun newsticker--treeview-list-immortal-items (widget changed-widget - &optional event) + &optional _event) "Fill newsticker treeview list window with immortal items. This is a callback function for the treeview nodes. Argument WIDGET is the calling treeview widget. @@ -393,7 +404,7 @@ Optional argument EVENT is the mouse event that triggered this action." "This is a virtual feed containing all immortal items.")) (defun newsticker--treeview-list-obsolete-items (widget changed-widget - &optional event) + &optional _event) "Fill newsticker treeview list window with obsolete items. This is a callback function for the treeview nodes. Argument WIDGET is the calling treeview widget. @@ -445,8 +456,8 @@ Optional argument EVENT is the mouse event that triggered this action." (cdr (newsticker--cache-get-feed (intern feed-name))))) (newsticker--treeview-list-update nil)))) -(defun newsticker--treeview-list-feed-items (widget changed-widget - &optional event) +(defun newsticker--treeview-list-feed-items (widget _changed-widget + &optional _event) "Callback function for listing feed items. Argument WIDGET is the calling treeview widget. Argument CHANGED-WIDGET is the widget that actually has changed. @@ -573,11 +584,10 @@ The sort function is chosen according to the value of (defun newsticker--treeview-list-update-highlight () "Update the highlight in the treeview list buffer." (newsticker--treeview-list-clear-highlight) - (let (pos num-lines) - (with-current-buffer (newsticker--treeview-list-buffer) - (let ((inhibit-read-only t)) - (put-text-property (point-at-bol) (point-at-eol) :nt-selected t)) - (newsticker--treeview-list-update-faces)))) + (with-current-buffer (newsticker--treeview-list-buffer) + (let ((inhibit-read-only t)) + (put-text-property (point-at-bol) (point-at-eol) :nt-selected t)) + (newsticker--treeview-list-update-faces))) (defun newsticker--treeview-list-highlight-start () "Return position of selection in treeview list buffer." @@ -654,23 +664,22 @@ for the button." (defun newsticker--treeview-list-select (item) "Select ITEM in treeview's list buffer." (newsticker--treeview-list-clear-highlight) - (let (pos num-lines) - (save-current-buffer - (set-buffer (newsticker--treeview-list-buffer)) - (goto-char (point-min)) - (catch 'found - (while t - (let ((it (get-text-property (point) :nt-item))) - (when (eq it item) - (newsticker--treeview-list-update-highlight) - (newsticker--treeview-list-update-faces) - (newsticker--treeview-item-show - item (get-text-property (point) :nt-feed)) - (throw 'found t))) - (forward-line 1) - (when (eobp) - (goto-char (point-min)) - (throw 'found nil))))))) + (save-current-buffer + (set-buffer (newsticker--treeview-list-buffer)) + (goto-char (point-min)) + (catch 'found + (while t + (let ((it (get-text-property (point) :nt-item))) + (when (eq it item) + (newsticker--treeview-list-update-highlight) + (newsticker--treeview-list-update-faces) + (newsticker--treeview-item-show + item (get-text-property (point) :nt-feed)) + (throw 'found t))) + (forward-line 1) + (when (eobp) + (goto-char (point-min)) + (throw 'found nil)))))) ;; ====================================================================== ;;; item window @@ -708,7 +717,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 +738,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 +784,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 +832,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,8 +845,25 @@ Callback function for tree widget that adds nodes for feeds and subgroups." :open t)))) group))) -(defun newsticker--treeview-tree-expand-status (tree &optional changed-widget - event) +(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. Optional arguments CHANGED-WIDGET and EVENT are ignored." (tree-widget-set-theme "folder") @@ -864,6 +896,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 () @@ -882,7 +915,7 @@ Optional arguments CHANGED-WIDGET and EVENT are ignored." :tag (newsticker--treeview-propertize-tag "Feeds" 0 "feeds") :expander 'newsticker--treeview-tree-expand - :expander-p (lambda (&rest ignore) t) + :expander-p (lambda (&rest _) t) :leaf-icon 'newsticker--tree-widget-leaf-icon :nt-group (cdr newsticker-groups) :nt-id "feeds" @@ -893,7 +926,7 @@ Optional arguments CHANGED-WIDGET and EVENT are ignored." :tag (newsticker--treeview-propertize-tag "Virtual Feeds" 0 "vfeeds") :expander 'newsticker--treeview-tree-expand-status - :expander-p (lambda (&rest ignore) t) + :expander-p (lambda (&rest _) t) :leaf-icon 'newsticker--tree-widget-leaf-icon :nt-id "vfeeds" :keep '(:nt-id) @@ -907,12 +940,13 @@ Optional arguments CHANGED-WIDGET and EVENT are ignored." "Return propertized copy of string TAG. Optional argument NUM-NEW is used for choosing face, other arguments NT-ID, FEED, and VFEED are added as properties." - ;;(message "newsticker--treeview-propertize-tag '%s' %s" feed nt-id) + ;;(message "newsticker--treeview-propertize-tag `%s' %s" feed nt-id) (let ((face 'newsticker-treeview-face) (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 @@ -955,10 +989,10 @@ Optional argument NT-ID is added to the tag's properties." (defun newsticker--stat-num-items-for-group (feed-name-symbol &rest ages) "Count number of items in feed FEED-NAME-SYMBOL that have an age matching AGES." ;;(message "newsticker--stat-num-items-for-group %s %s" feed-name-symbol ages) - (let ((result (apply 'newsticker--stat-num-items feed-name-symbol ages))) + (let ((result (apply #'newsticker--stat-num-items feed-name-symbol ages))) (mapc (lambda (f-n) (setq result (+ result - (apply 'newsticker--stat-num-items (intern f-n) + (apply #'newsticker--stat-num-items (intern f-n) ages)))) (newsticker--group-get-feeds (newsticker--group-get-group (symbol-name feed-name-symbol)) t)) @@ -984,7 +1018,7 @@ the feed is a virtual feed." num-new)) (defun newsticker--treeview-tree-update-tag (w &optional recursive - &rest ignore) + &rest _ignore) "Update tag for tree widget W. If RECURSIVE is non-nil recursively update parent widgets as well. Argument IGNORE is ignored. Note that this function, if @@ -1007,8 +1041,7 @@ that case." (widget-put w :num-new num-new) (widget-put w :tag tag) (when (marker-position (widget-get w :from)) - (let ((p (point)) - (notify (widget-get w :notify))) + (let ((p (point))) ;; FIXME: This moves point!!!! (with-current-buffer (newsticker--treeview-tree-buffer) (widget-value-set w (widget-value w))) @@ -1022,9 +1055,9 @@ that case." (newsticker--treeview-tree-do-update-tags w)) (newsticker--treeview-tree-update-tag widget)))) -(defun newsticker--treeview-tree-update-tags (&rest ignore) +(defun newsticker--treeview-tree-update-tags (&rest _ignore) "Update all tags of all trees. -Arguments IGNORE are ignored." +Arguments are ignored." (save-current-buffer (set-buffer (newsticker--treeview-tree-buffer)) (let ((inhibit-read-only t)) @@ -1158,12 +1191,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 +1245,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 +1262,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-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"))) (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-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) @@ -1590,10 +1636,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 @@ -1609,28 +1653,39 @@ Return t if a new feed was activated, nil otherwise." (completing-read "Jump to feed: " (append '("new" "obsolete" "immortal" "all") - (mapcar 'car (append newsticker-url-list - newsticker-url-list-defaults))) + (mapcar #'car (append newsticker-url-list + newsticker-url-list-defaults))) nil t)))) (newsticker--treeview-unfold-node feed-name)) ;; ====================================================================== ;;; 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 +1706,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 +1741,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 +1753,155 @@ 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 +1948,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 +1961,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,16 +2035,18 @@ 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.") -(defun newsticker-treeview-mode () +(define-derived-mode newsticker-treeview-mode fundamental-mode "Newsticker TV" "Major mode for Newsticker Treeview. \\{newsticker-treeview-mode-map}" - (kill-all-local-variables) - (use-local-map newsticker-treeview-mode-map) - (setq major-mode 'newsticker-treeview-mode) - (setq mode-name "Newsticker TV") (if (boundp 'tool-bar-map) (set (make-local-variable 'tool-bar-map) newsticker-treeview-tool-bar-map)) @@ -1954,7 +2085,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. @@ -1968,13 +2099,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 bc95ad30452..9b16c1f0749 100644 --- a/lisp/net/newsticker.el +++ b/lisp/net/newsticker.el @@ -1,14 +1,12 @@ ;;; newsticker.el --- A Newsticker for Emacs. -;; Copyright (C) 2003-2013 Free Software Foundation, Inc. +;; Copyright (C) 2003-2015 Free Software Foundation, Inc. ;; Author: Ulf Jasper <ulf.jasper@web.de> ;; Filename: newsticker.el ;; 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: @@ -378,7 +377,7 @@ ;; * Remove stupid newlines in titles (headlines) -- Thanks to ;; Jeff Rancier. -;; 0.94 * Added clickerability and description for channel headings. +;; 0.94 * Added clickability and description for channel headings. ;; * Made it work for (at least some) rss 0.9<something> feeds. ;; 0.93 * Added some more sites. diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el new file mode 100644 index 00000000000..c54553ae5ea --- /dev/null +++ b/lisp/net/nsm.el @@ -0,0 +1,508 @@ +;;; 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.") + +(declare-function gnutls-peer-status "gnutls.c" (proc)) + +(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))) + +(declare-function gnutls-peer-status-warning-describe "gnutls.c" + (status-symbol)) + +(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 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 "") + (cursor-in-echo-area t) + 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 1a9d99e012f..ff7e79e5aa6 100644 --- a/lisp/net/ntlm.el +++ b/lisp/net/ntlm.el @@ -1,10 +1,11 @@ ;;; ntlm.el --- NTLM (NT LanManager) authentication support -;; Copyright (C) 2001, 2007-2013 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2007-2015 Free Software Foundation, Inc. ;; Author: Taro Kawagishi <tarok@transpulse.org> -;; Keywords: NTLM, SASL -;; Version: 1.00 +;; Maintainer: Thomas Fitzsimmons <fitzsim@fitzsim.org> +;; Keywords: NTLM, SASL, comm +;; Version: 2.00 ;; Created: February 2001 ;; This file is part of GNU Emacs. @@ -65,6 +66,27 @@ ;;; Code: (require 'md4) +(require 'hmac-md5) +(require 'calc) + +(defgroup ntlm nil + "NTLM (NT LanManager) authentication." + :version "25.1" + :group 'comm) + +(defcustom ntlm-compatibility-level 5 + "The NTLM compatibility level. +Ordered from 0, the oldest, least-secure level through 5, the +newest, most-secure level. Newer servers may reject lower +levels. At levels 3 through 5, send LMv2 and NTLMv2 responses. +At levels 0, 1 and 2, send LM and NTLM responses. + +In this implementation, levels 0, 1 and 2 are the same (old, +insecure), and levels 3, 4 and 5 are the same (new, secure). If +NTLM authentication isn't working at level 5, try level 0. The +other levels are only present because other clients have six +levels." + :type '(choice (const 0) (const 1) (const 2) (const 3) (const 4) (const 5))) ;;; ;;; NTLM authentication interface functions @@ -80,8 +102,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 @@ -112,6 +134,39 @@ is not given." `(string-as-unibyte ,string) string))) +(defun ntlm-compute-timestamp () + "Compute 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." + (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)") + ;; add trailing zeros to support old current-time formats + 'rawnum (append (current-time) '(0 0)))) + 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)))) + +(defun ntlm-generate-nonce () + "Generate a random nonce, not to be used more than once. +Return a random eight byte unibyte string." + (unibyte-string + (random 256) (random 256) (random 256) (random 256) + (random 256) (random 256) (random 256) (random 256))) + (defun ntlm-build-auth-response (challenge user password-hashes) "Return the response string to a challenge string CHALLENGE given by the NTLM based server for the user USER and the password hash list @@ -128,9 +183,9 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of uDomain-len uDomain-offs ;; response struct and its fields lmRespData ;lmRespData, 24 bytes - ntRespData ;ntRespData, 24 bytes + ntRespData ;ntRespData, variable length domain ;ascii domain string - lu ld off-lm off-nt off-d off-u off-w off-s) + lu ld ln off-lm off-nt off-d off-u off-w off-s) ;; extract domain string from challenge string (setq uDomain-len (md4-unpack-int16 (substring uDomain 0 2))) (setq uDomain-offs (md4-unpack-int32 (substring uDomain 4 8))) @@ -144,21 +199,79 @@ 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)) + (unless (and (integerp ntlm-compatibility-level) + (>= ntlm-compatibility-level 0) + (<= ntlm-compatibility-level 5)) + (error "Invalid ntlm-compatibility-level value")) + (if (and (>= ntlm-compatibility-level 3) + (<= ntlm-compatibility-level 5)) + ;; extract target information block, if it is present + (if (< (cdr uDomain-offs) 48) + (error "Failed to find target information block") + (let* ((targetInfo-len (md4-unpack-int16 (substring rchallenge + 40 42))) + (targetInfo-offs (md4-unpack-int32 (substring rchallenge + 44 48))) + (targetInfo (substring rchallenge + (cdr targetInfo-offs) + (+ (cdr targetInfo-offs) + targetInfo-len))) + (upcase-user (upcase (ntlm-ascii2unicode user (length user)))) + (ntlmv2-hash (hmac-md5 (concat upcase-user + (ntlm-ascii2unicode + domain (length domain))) + (cadr password-hashes))) + (nonce (ntlm-generate-nonce)) + (blob (concat (make-string 2 1) + (make-string 2 0) ; blob signature + (make-string 4 0) ; reserved value + (ntlm-compute-timestamp) ; timestamp + nonce ; client nonce + (make-string 4 0) ; unknown + targetInfo ; target info + (make-string 4 0))) ; unknown + ;; for reference: LMv2 interim calculation + ;; (lm-interim (hmac-md5 (concat challengeData nonce) + ;; ntlmv2-hash)) + (nt-interim (hmac-md5 (concat challengeData blob) + ntlmv2-hash))) + ;; for reference: LMv2 field, but match other clients that + ;; send all zeros + ;; (setq lmRespData (concat lm-interim nonce)) + (setq lmRespData (make-string 24 0)) + (setq ntRespData (concat nt-interim blob)))) + ;; compatibility level is 2, 1 or 0 + ;; level 2 should be treated specially but it's not clear how, + ;; so just treat it the same as levels 0 and 1 + ;; 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 (ntlm-generate-nonce)) + (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))) + ;; 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)) (setq ld (length domain)) + (setq ln (length ntRespData)) (setq off-lm 64) ;offset to string 'lmResponse (setq off-nt (+ 64 24)) ;offset to string 'ntResponse - (setq off-d (+ 64 48)) ;offset to string 'uDomain - (setq off-u (+ 64 48 (* 2 ld))) ;offset to string 'uUser - (setq off-w (+ 64 48 (* 2 (+ ld lu)))) ;offset to string 'uWks - (setq off-s (+ 64 48 (* 2 (+ ld lu lu)))) ;offset to string 'sessionKey + (setq off-d (+ 64 24 ln)) ;offset to string 'uDomain + (setq off-u (+ 64 24 ln (* 2 ld))) ;offset to string 'uUser + (setq off-w (+ 64 24 ln (* 2 (+ ld lu)))) ;offset to string 'uWks + (setq off-s (+ 64 24 ln (* 2 (+ ld lu lu)))) ;offset to string 'sessionKey ;; pack the response struct in a string (concat "NTLMSSP\0" ;response ident field, 8 bytes (md4-pack-int32 '(0 . 3)) ;response msgType field, 4 bytes @@ -170,9 +283,9 @@ by PASSWORD-HASHES. PASSWORD-HASHES should be a return value of (md4-pack-int32 (cons 0 off-lm)) ;field offset ;; ntResponse field, 8 bytes - ;;AddBytes(response,ntResponse,ntRespData,24); - (md4-pack-int16 24) ;len field - (md4-pack-int16 24) ;maxlen field + ;;AddBytes(response,ntResponse,ntRespData,ln); + (md4-pack-int16 ln) ;len field + (md4-pack-int16 ln) ;maxlen field (md4-pack-int32 (cons 0 off-nt)) ;field offset ;; uDomain field, 8 bytes diff --git a/lisp/net/pinentry.el b/lisp/net/pinentry.el new file mode 100644 index 00000000000..eaa9fa40b12 --- /dev/null +++ b/lisp/net/pinentry.el @@ -0,0 +1,452 @@ +;;; pinentry.el --- GnuPG Pinentry server implementation -*- lexical-binding: t -*- + +;; Copyright (C) 2015 Free Software Foundation, Inc. + +;; Author: Daiki Ueno <ueno@gnu.org> +;; Version: 0.1 +;; Keywords: GnuPG + +;; 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: + +;; This package allows GnuPG passphrase to be prompted through the +;; minibuffer instead of graphical dialog. +;; +;; To use, add allow-emacs-pinentry to ~/.gnupg/gpg-agent.conf, and +;; start the server with M-x pinentry-start. +;; +;; The actual communication path between the relevant components is +;; as follows: +;; +;; gpg --> gpg-agent --> pinentry --> Emacs +;; +;; where pinentry and Emacs communicate through a Unix domain socket +;; created at: +;; +;; ${TMPDIR-/tmp}/emacs$(id -u)/pinentry +;; +;; under the same directory which server.el uses. The protocol is a +;; subset of the Pinentry Assuan protocol described in (info +;; "(pinentry) Protocol"). +;; +;; NOTE: As of August 2015, this feature requires newer versions of +;; GnuPG (2.1.5+) and Pinentry (0.9.5+). + +;;; Code: + +(defgroup pinentry nil + "The Pinentry server" + :version "25.1" + :group 'external) + +(defcustom pinentry-popup-prompt-window t + "If non-nil, display multiline prompt in another window." + :type 'boolean + :group 'pinentry) + +(defcustom pinentry-prompt-window-height 5 + "Number of lines used to display multiline prompt." + :type 'integer + :group 'pinentry) + +(defvar pinentry-debug nil) +(defvar pinentry-debug-buffer nil) +(defvar pinentry--server-process nil) +(defvar pinentry--connection-process-list nil) + +(defvar pinentry--labels nil) +(put 'pinentry-read-point 'permanent-local t) +(defvar pinentry--read-point nil) +(put 'pinentry--read-point 'permanent-local t) + +(defvar pinentry--prompt-buffer nil) + +;; We use the same location as `server-socket-dir', when local sockets +;; are supported. +(defvar pinentry--socket-dir + (format "%s/emacs%d" (or (getenv "TMPDIR") "/tmp") (user-uid)) + "The directory in which to place the server socket. +If local sockets are not supported, this is nil.") + +(defconst pinentry--set-label-commands + '("SETPROMPT" "SETTITLE" "SETDESC" + "SETREPEAT" "SETREPEATERROR" + "SETOK" "SETCANCEL" "SETNOTOK")) + +;; These error codes are defined in libgpg-error/src/err-codes.h.in. +(defmacro pinentry--error-code (code) + (logior (lsh 5 24) code)) +(defconst pinentry--error-not-implemented + (cons (pinentry--error-code 69) "not implemented")) +(defconst pinentry--error-cancelled + (cons (pinentry--error-code 99) "cancelled")) +(defconst pinentry--error-not-confirmed + (cons (pinentry--error-code 114) "not confirmed")) + +(autoload 'server-ensure-safe-dir "server") + +(defvar pinentry-prompt-mode-map + (let ((keymap (make-sparse-keymap))) + (define-key keymap "q" 'quit-window) + keymap)) + +(define-derived-mode pinentry-prompt-mode special-mode "Pinentry" + "Major mode for `pinentry--prompt-buffer'." + (buffer-disable-undo) + (setq truncate-lines t + buffer-read-only t)) + +(defun pinentry--prompt (labels query-function &rest query-args) + (let ((desc (cdr (assq 'desc labels))) + (error (cdr (assq 'error labels))) + (prompt (cdr (assq 'prompt labels)))) + (when (string-match "[ \n]*\\'" prompt) + (setq prompt (concat + (substring + prompt 0 (match-beginning 0)) " "))) + (when error + (setq desc (concat "Error: " (propertize error 'face 'error) + "\n" desc))) + (if (and desc pinentry-popup-prompt-window) + (save-window-excursion + (delete-other-windows) + (unless (and pinentry--prompt-buffer + (buffer-live-p pinentry--prompt-buffer)) + (setq pinentry--prompt-buffer (generate-new-buffer "*Pinentry*"))) + (if (get-buffer-window pinentry--prompt-buffer) + (delete-window (get-buffer-window pinentry--prompt-buffer))) + (with-current-buffer pinentry--prompt-buffer + (let ((inhibit-read-only t) + buffer-read-only) + (erase-buffer) + (insert desc)) + (pinentry-prompt-mode) + (goto-char (point-min))) + (if (> (window-height) + pinentry-prompt-window-height) + (set-window-buffer (split-window nil + (- (window-height) + pinentry-prompt-window-height)) + pinentry--prompt-buffer) + (pop-to-buffer pinentry--prompt-buffer) + (if (> (window-height) pinentry-prompt-window-height) + (shrink-window (- (window-height) + pinentry-prompt-window-height)))) + (prog1 (apply query-function prompt query-args) + (quit-window))) + (apply query-function (concat desc "\n" prompt) query-args)))) + +;;;###autoload +(defun pinentry-start () + "Start a Pinentry service. + +Once the environment is properly set, subsequent invocations of +the gpg command will interact with Emacs for passphrase input." + (interactive) + (unless (featurep 'make-network-process '(:family local)) + (error "local sockets are not supported")) + (if (process-live-p pinentry--server-process) + (message "Pinentry service is already running") + (let* ((server-file (expand-file-name "pinentry" pinentry--socket-dir))) + (server-ensure-safe-dir pinentry--socket-dir) + ;; Delete the socket files made by previous server invocations. + (ignore-errors + (let (delete-by-moving-to-trash) + (delete-file server-file))) + (setq pinentry--server-process + (make-network-process + :name "pinentry" + :server t + :noquery t + :sentinel #'pinentry--process-sentinel + :filter #'pinentry--process-filter + :coding 'no-conversion + :family 'local + :service server-file)) + (process-put pinentry--server-process :server-file server-file)))) + +(defun pinentry-stop () + "Stop a Pinentry service." + (interactive) + (when (process-live-p pinentry--server-process) + (delete-process pinentry--server-process)) + (setq pinentry--server-process nil) + (dolist (process pinentry--connection-process-list) + (when (buffer-live-p (process-buffer process)) + (kill-buffer (process-buffer process)))) + (setq pinentry--connection-process-list nil)) + +(defun pinentry--labels-to-shortcuts (labels) + "Convert strings in LABEL by stripping mnemonics." + (mapcar (lambda (label) + (when label + (let (c) + (if (string-match "\\(?:\\`\\|[^_]\\)_\\([[:alnum:]]\\)" label) + (let ((key (match-string 1 label))) + (setq c (downcase (aref key 0))) + (setq label (replace-match + (propertize key 'face 'underline) + t t label))) + (setq c (if (= (length label) 0) + ?? + (downcase (aref label 0))))) + ;; Double underscores mean a single underscore. + (when (string-match "__" label) + (setq label (replace-match "_" t t label))) + (cons c label)))) + labels)) + +(defun pinentry--escape-string (string) + "Escape STRING in the Assuan percent escape." + (let ((length (length string)) + (index 0) + (count 0)) + (while (< index length) + (if (memq (aref string index) '(?\n ?\r ?%)) + (setq count (1+ count))) + (setq index (1+ index))) + (setq index 0) + (let ((result (make-string (+ length (* count 2)) ?\0)) + (result-index 0) + c) + (while (< index length) + (setq c (aref string index)) + (if (memq c '(?\n ?\r ?%)) + (let ((hex (format "%02X" c))) + (aset result result-index ?%) + (setq result-index (1+ result-index)) + (aset result result-index (aref hex 0)) + (setq result-index (1+ result-index)) + (aset result result-index (aref hex 1)) + (setq result-index (1+ result-index))) + (aset result result-index c) + (setq result-index (1+ result-index))) + (setq index (1+ index))) + result))) + +(defun pinentry--unescape-string (string) + "Unescape STRING in the Assuan percent escape." + (let ((length (length string)) + (index 0)) + (let ((result (make-string length ?\0)) + (result-index 0) + c) + (while (< index length) + (setq c (aref string index)) + (if (and (eq c '?%) (< (+ index 2) length)) + (progn + (aset result result-index + (string-to-number (substring string + (1+ index) + (+ index 3)) + 16)) + (setq result-index (1+ result-index)) + (setq index (+ index 2))) + (aset result result-index c) + (setq result-index (1+ result-index))) + (setq index (1+ index))) + (substring result 0 result-index)))) + +(defun pinentry--send-data (process escaped) + "Send a string ESCAPED to a process PROCESS. +ESCAPED will be split if it exceeds the line length limit of the +Assuan protocol." + (let ((length (length escaped)) + (index 0)) + (if (= length 0) + (process-send-string process "D \n") + (while (< index length) + ;; 997 = ASSUAN_LINELENGTH (= 1000) - strlen ("D \n") + (let* ((sub-length (min (- length index) 997)) + (sub (substring escaped index (+ index sub-length)))) + (unwind-protect + (progn + (process-send-string process "D ") + (process-send-string process sub) + (process-send-string process "\n")) + (clear-string sub)) + (setq index (+ index sub-length))))))) + +(defun pinentry--send-error (process error) + (process-send-string process (format "ERR %d %s\n" (car error) (cdr error)))) + +(defun pinentry--process-filter (process input) + (unless (buffer-live-p (process-buffer process)) + (let ((buffer (generate-new-buffer " *pinentry*"))) + (set-process-buffer process buffer) + (with-current-buffer buffer + (if (fboundp 'set-buffer-multibyte) + (set-buffer-multibyte nil)) + (make-local-variable 'pinentry--read-point) + (setq pinentry--read-point (point-min)) + (make-local-variable 'pinentry--labels)))) + (with-current-buffer (process-buffer process) + (when pinentry-debug + (with-current-buffer + (or pinentry-debug-buffer + (setq pinentry-debug-buffer (generate-new-buffer + " *pinentry-debug*"))) + (goto-char (point-max)) + (insert input))) + (save-excursion + (goto-char (point-max)) + (insert input) + (goto-char pinentry--read-point) + (beginning-of-line) + (while (looking-at ".*\n") ;the input line finished + (if (looking-at "\\([A-Z_]+\\) ?\\(.*\\)") + (let ((command (match-string 1)) + (string (pinentry--unescape-string (match-string 2)))) + (pcase command + ((and set (guard (member set pinentry--set-label-commands))) + (when (> (length string) 0) + (let* ((symbol (intern (downcase (substring set 3)))) + (entry (assq symbol pinentry--labels)) + (label (decode-coding-string string 'utf-8))) + (if entry + (setcdr entry label) + (push (cons symbol label) pinentry--labels)))) + (ignore-errors + (process-send-string process "OK\n"))) + ("NOP" + (ignore-errors + (process-send-string process "OK\n"))) + ("GETPIN" + (let ((confirm (not (null (assq 'repeat pinentry--labels)))) + passphrase escaped-passphrase encoded-passphrase) + (unwind-protect + (condition-case err + (progn + (setq passphrase + (pinentry--prompt + pinentry--labels + #'read-passwd confirm)) + (setq escaped-passphrase + (pinentry--escape-string + passphrase)) + (setq encoded-passphrase (encode-coding-string + escaped-passphrase + 'utf-8)) + (ignore-errors + (pinentry--send-data + process encoded-passphrase) + (process-send-string process "OK\n"))) + (error + (message "GETPIN error %S" err) + (ignore-errors + (pinentry--send-error + process + pinentry--error-cancelled)))) + (if passphrase + (clear-string passphrase)) + (if escaped-passphrase + (clear-string escaped-passphrase)) + (if encoded-passphrase + (clear-string encoded-passphrase)))) + (setq pinentry--labels nil)) + ("CONFIRM" + (let ((prompt + (or (cdr (assq 'prompt pinentry--labels)) + "Confirm? ")) + (buttons + (delq nil + (pinentry--labels-to-shortcuts + (list (cdr (assq 'ok pinentry--labels)) + (cdr (assq 'notok pinentry--labels)) + (cdr (assq 'cancel pinentry--labels)))))) + entry) + (if buttons + (progn + (setq prompt + (concat prompt " (" + (mapconcat #'cdr buttons + ", ") + ") ")) + (if (setq entry (assq 'prompt pinentry--labels)) + (setcdr entry prompt) + (setq pinentry--labels (cons (cons 'prompt prompt) + pinentry--labels))) + (condition-case nil + (let ((result (pinentry--prompt pinentry--labels + #'read-char))) + (if (eq result (caar buttons)) + (ignore-errors + (process-send-string process "OK\n")) + (if (eq result (car (nth 1 buttons))) + (ignore-errors + (pinentry--send-error + process + pinentry--error-not-confirmed)) + (ignore-errors + (pinentry--send-error + process + pinentry--error-cancelled))))) + (error + (ignore-errors + (pinentry--send-error + process + pinentry--error-cancelled))))) + (if (setq entry (assq 'prompt pinentry--labels)) + (setcdr entry prompt) + (setq pinentry--labels (cons (cons 'prompt prompt) + pinentry--labels))) + (if (condition-case nil + (pinentry--prompt pinentry--labels #'y-or-n-p) + (quit)) + (ignore-errors + (process-send-string process "OK\n")) + (ignore-errors + (pinentry--send-error + process + pinentry--error-not-confirmed)))) + (setq pinentry--labels nil))) + (_ (ignore-errors + (pinentry--send-error + process + pinentry--error-not-implemented)))) + (forward-line) + (setq pinentry--read-point (point)))))))) + +(defun pinentry--process-sentinel (process _status) + "The process sentinel for Emacs server connections." + ;; If this is a new client process, set the query-on-exit flag to nil + ;; for this process (it isn't inherited from the server process). + (when (and (eq (process-status process) 'open) + (process-query-on-exit-flag process)) + (push process pinentry--connection-process-list) + (set-process-query-on-exit-flag process nil) + (ignore-errors + (process-send-string process "OK Your orders please\n"))) + ;; Kill the process buffer of the connection process. + (when (and (not (process-contact process :server)) + (eq (process-status process) 'closed)) + (when (buffer-live-p (process-buffer process)) + (kill-buffer (process-buffer process))) + (setq pinentry--connection-process-list + (delq process pinentry--connection-process-list))) + ;; Delete the associated connection file, if applicable. + ;; Although there's no 100% guarantee that the file is owned by the + ;; running Emacs instance, server-start uses server-running-p to check + ;; for possible servers before doing anything, so it *should* be ours. + (and (process-contact process :server) + (eq (process-status process) 'closed) + (ignore-errors + (delete-file (process-get process :server-file))))) + +(provide 'pinentry) + +;;; pinentry.el ends here diff --git a/lisp/net/quickurl.el b/lisp/net/quickurl.el index 1e05d8db336..2d571254d35 100644 --- a/lisp/net/quickurl.el +++ b/lisp/net/quickurl.el @@ -1,6 +1,6 @@ ;;; quickurl.el --- insert a URL based on text at point in buffer -;; Copyright (C) 1999-2013 Free Software Foundation, Inc. +;; Copyright (C) 1999-2015 Free Software Foundation, Inc. ;; Author: Dave Pearson <davep@davep.org> ;; Maintainer: Dave Pearson <davep@davep.org> @@ -97,6 +97,7 @@ (defcustom quickurl-url-file (locate-user-emacs-file "quickurls" ".quickurls") "File that contains the URL list." + :version "24.4" ; added locate-user-emacs-file :type 'file :group 'quickurl) @@ -429,18 +430,12 @@ current buffer, this default action can be modified via (put 'quickurl-list-mode 'mode-class 'special) ;;;###autoload -(defun quickurl-list-mode () +(define-derived-mode quickurl-list-mode fundamental-mode "quickurl list" "A mode for browsing the quickurl URL list. The key bindings for `quickurl-list-mode' are: \\{quickurl-list-mode-map}" - (interactive) - (kill-all-local-variables) - (use-local-map quickurl-list-mode-map) - (setq major-mode 'quickurl-list-mode - mode-name "quickurl list") - (run-mode-hooks 'quickurl-list-mode-hook) (setq buffer-read-only t truncate-lines t)) diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index 2d8da415295..d58f3ebd4ea 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-2013 Free Software Foundation, Inc. +;; 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." @@ -881,7 +904,10 @@ The list is updated automatically by `defun-rcirc-command'.") "Function used for `completion-at-point-functions' in `rcirc-mode'." (and (rcirc-looking-at-input) (let* ((beg (save-excursion - (if (re-search-backward " " rcirc-prompt-end-marker t) + ;; On some networks it is common to message or + ;; mention someone using @nick instead of just + ;; nick. + (if (re-search-backward "[[:space:]@]" rcirc-prompt-end-marker t) (1+ (point)) rcirc-prompt-end-marker))) (table (if (and (= beg rcirc-prompt-end-marker) @@ -900,7 +926,7 @@ The list is updated automatically by `defun-rcirc-command'.") (defun rcirc-complete () "Cycle through completions from list of nicks in channel or IRC commands. -IRC command completion is performed only if '/' is the first input char." +IRC command completion is performed only if `/' is the first input char." (interactive) (unless (rcirc-looking-at-input) (error "Point not located after rcirc prompt")) @@ -928,12 +954,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 +1016,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 +1050,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 +1249,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) @@ -1348,7 +1375,7 @@ if ARG is omitted or nil." (t . "%fp*** %fs%n %r %m")) "An alist of formats used for printing responses. The format is looked up using the response-type as a key; -if no match is found, the default entry (with a key of `t') is used. +if no match is found, the default entry (with a key of t) is used. The entry's value part should be a string, which is inserted with the of the following escape sequences replaced by the described values: @@ -1393,9 +1420,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 +1458,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 +1501,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 +1909,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." @@ -1899,17 +1927,13 @@ Uninteresting lines are those whose responses are listed in (goto-char overlay-arrow-position) (message "No unread messages"))) -(defun rcirc-non-irc-buffer () - (let ((buflist (buffer-list)) - buffer) - (while (and buflist (not buffer)) - (with-current-buffer (car buflist) - (unless (or (eq major-mode 'rcirc-mode) - (= ?\s (aref (buffer-name) 0)) ; internal buffers - (get-buffer-window (current-buffer))) - (setq buffer (current-buffer)))) - (setq buflist (cdr buflist))) - buffer)) +(defun rcirc-bury-buffers () + "Bury all RCIRC buffers." + (interactive) + (dolist (buf (buffer-list)) + (when (eq 'rcirc-mode (with-current-buffer buf major-mode)) + (bury-buffer buf) ; buffers not shown + (quit-windows-on buf)))) ; buffers shown in a window (defun rcirc-next-active-buffer (arg) "Switch to the next rcirc buffer with activity. @@ -1924,15 +1948,13 @@ With prefix ARG, go to the next low priority buffer with activity." (switch-to-buffer (car (if arg lopri hipri))) (when (> (point) rcirc-prompt-start-marker) (recenter -1))) - (if (eq major-mode 'rcirc-mode) - (switch-to-buffer (rcirc-non-irc-buffer)) - (message "%s" (concat - "No IRC activity." - (when lopri - (concat - " Type C-u " - (key-description (this-command-keys)) - " for low priority activity.")))))))) + (rcirc-bury-buffers) + (message "No IRC activity.%s" + (if lopri + (concat + " Type C-u " (key-description (this-command-keys)) + " for low priority activity.") + ""))))) (define-obsolete-variable-alias 'rcirc-activity-hooks 'rcirc-activity-functions "24.3") @@ -1950,12 +1972,13 @@ activity. Only run if the buffer is not visible and (old-types rcirc-activity-types)) (when (not (get-buffer-window (current-buffer) t)) (setq rcirc-activity - (sort (add-to-list 'rcirc-activity (current-buffer)) + (sort (if (memq (current-buffer) rcirc-activity) rcirc-activity + (cons (current-buffer) rcirc-activity)) (lambda (b1 b2) (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))))) @@ -1976,13 +1999,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.") @@ -2014,7 +2037,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))) @@ -2122,7 +2145,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 @@ -2141,6 +2164,7 @@ activity. Only run if the buffer is not visible and ,interactive-form (let ((process (or process (rcirc-buffer-process))) (target (or target rcirc-target))) + (ignore target) ; mark `target' variable as ignorable ,@body)))) (defun-rcirc-command msg (message) @@ -2210,6 +2234,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") @@ -2280,7 +2317,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))) @@ -2291,7 +2328,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))) @@ -2360,10 +2397,11 @@ keywords when no KEYWORD is given." (let ((pos start) next prop) (while (< pos end) - (setq prop (get-text-property pos 'face object) - next (next-single-property-change pos 'face object end)) - (unless (member name (get-text-property pos 'face object)) - (add-text-properties pos next (list 'face (cons name prop)) object)) + (setq prop (get-text-property pos 'font-lock-face object) + next (next-single-property-change pos 'font-lock-face object end)) + (unless (member name (get-text-property pos 'font-lock-face object)) + (add-text-properties pos next + (list 'font-lock-face (cons name prop)) object)) (setq pos next))))) (defun rcirc-facify (string face) @@ -2410,21 +2448,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))) @@ -2438,7 +2475,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 @@ -2452,7 +2489,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)) @@ -2483,7 +2520,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 @@ -2491,16 +2528,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)))) @@ -2564,7 +2600,7 @@ If ARG is given, opens the URL in a new browser window." (cond ((rcirc-channel-p target) target) ;;; -ChanServ- [#gnu] Welcome... - ((string-match "\\[\\(#[^\] ]+\\)\\]" message) + ((string-match "\\[\\(#[^] ]+\\)\\]" message) (match-string 1 message)) (sender (if (string= sender (rcirc-server-name process)) @@ -2572,7 +2608,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." @@ -2600,10 +2636,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 @@ -2624,7 +2660,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 @@ -2641,7 +2677,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))) @@ -2652,10 +2688,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 (nth 2 args)) (message (concat nick " " channel " " reason))) (rcirc-print process sender "KICK" channel message t) ;; print in private chat buffer if it exists @@ -2680,7 +2716,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 @@ -2690,7 +2726,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))) @@ -2721,25 +2757,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 (nth 2 args))) (when (or (not rec) (not (string= (cdr rec) away-message))) ;; away message has changed @@ -2749,7 +2785,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))) @@ -2763,31 +2799,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 (nth 2 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 (nth 2 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) (nth 2 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" @@ -2807,7 +2843,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) ""))) @@ -2820,7 +2856,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))) @@ -2845,14 +2881,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 (nth 2 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 @@ -2876,10 +2912,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) @@ -2897,7 +2933,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 @@ -2906,12 +2942,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/rcompile.el b/lisp/net/rcompile.el deleted file mode 100644 index e7bfbf386f4..00000000000 --- a/lisp/net/rcompile.el +++ /dev/null @@ -1,180 +0,0 @@ -;;; rcompile.el --- run a compilation on a remote machine - -;; Copyright (C) 1993-1994, 2001-2013 Free Software Foundation, Inc. - -;; Author: Alon Albert <alon@milcse.rtsg.mot.com> -;; Maintainer: FSF -;; Created: 1993 Oct 6 -;; Keywords: tools, processes - -;; 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: - -;; This package is for running a remote compilation and using emacs to parse -;; the error messages. It works by rsh'ing the compilation to a remote host -;; and parsing the output. If the file visited at the time remote-compile was -;; called was loaded remotely (ange-ftp), the host and user name are obtained -;; by the calling ange-ftp-ftp-name on the current directory. In this case the -;; next-error command will also ange-ftp the files over. This is achieved -;; automatically because the compilation-parse-errors function uses -;; default-directory to build its file names. If however the file visited was -;; loaded locally, remote-compile prompts for a host and user and assumes the -;; files mounted locally (otherwise, how was the visited file loaded). - -;; See the user defined variables section for more info. - -;; I was contemplating redefining "compile" to "remote-compile" automatically -;; if the file visited was ange-ftp'ed but decided against it for now. If you -;; feel this is a good idea, let me know and I'll consider it again. - -;; Installation: - -;; To use rcompile, you also need to give yourself permission to connect to -;; the remote host. You do this by putting lines like: - -;; monopoly alon -;; vme33 -;; -;; in a file named .rhosts in the home directory (of the remote machine). -;; Be careful what you put in this file. A line like: -;; -;; + -;; -;; Will allow anyone access to your account without a password. I suggest you -;; read the rhosts(5) manual page before you edit this file (if you are not -;; familiar with it already) - -;;; Code: - -(provide 'rcompile) -(require 'compile) -;;; The following should not be needed. -;;; (eval-when-compile (require 'ange-ftp)) - -;;;; user defined variables - -(defgroup remote-compile nil - "Run a compilation on a remote machine." - :group 'processes - :group 'tools) - - -(defcustom remote-compile-host nil - "Host for remote compilations." - :type '(choice string (const nil)) - :group 'remote-compile) - -(defcustom remote-compile-user nil - "User for remote compilations. -nil means use the value returned by \\[user-login-name]." - :type '(choice string (const nil)) - :group 'remote-compile) - -(defcustom remote-compile-run-before nil - "Command to run before compilation. -This can be used for setting up environment variables, -since rsh does not invoke the shell as a login shell and files like .login -\(tcsh\) and .bash_profile \(bash\) are not run. -nil means run no commands." - :type '(choice string (const nil)) - :group 'remote-compile) - -(defcustom remote-compile-prompt-for-host nil - "Non-nil means prompt for host if not available from filename." - :type 'boolean - :group 'remote-compile) - -(defcustom remote-compile-prompt-for-user nil - "Non-nil means prompt for user if not available from filename." - :type 'boolean - :group 'remote-compile) - -;;;; internal variables - -;; History of remote compile hosts and users -(defvar remote-compile-host-history nil) -(defvar remote-compile-user-history nil) - - -;;;; entry point - -;; We use the Tramp internal function`tramp-make-tramp-file-name'. -;; Better would be, if there are functions to provide user, host and -;; localname of a remote filename, independent of Tramp's implementation. -;; The function calls are wrapped by `funcall' in order to pacify the byte -;; compiler. ange-ftp check removed, because it is handled also by Tramp. -;;;###autoload -(defun remote-compile (host user command) - "Compile the current buffer's directory on HOST. Log in as USER. -See \\[compile]." - (interactive - (let (host user command prompt l l-host l-user) - (setq prompt (if (stringp remote-compile-host) - (format "Compile on host (default %s): " - remote-compile-host) - "Compile on host: ") - host (if (or remote-compile-prompt-for-host - (null remote-compile-host)) - (read-from-minibuffer prompt - "" nil nil - 'remote-compile-host-history) - remote-compile-host) - user (if remote-compile-prompt-for-user - (read-from-minibuffer (format - "Compile by user (default %s): " - (or remote-compile-user - (user-login-name))) - "" nil nil - 'remote-compile-user-history) - remote-compile-user)) - (setq command (read-from-minibuffer "Compile command: " - compile-command nil nil - '(compile-history . 1))) - (list (if (string= host "") remote-compile-host host) - (if (string= user "") remote-compile-user user) - command))) - (setq compile-command command) - (cond (user - (setq remote-compile-user user)) - ((null remote-compile-user) - (setq remote-compile-user (user-login-name)))) - (let* (localname ;; Pacify byte-compiler. - (compile-command - (format "%s %s -l %s \"(%scd %s; %s)\"" - remote-shell-program - host - remote-compile-user - (if remote-compile-run-before - (concat remote-compile-run-before "; ") - "") - "" - compile-command))) - (setq remote-compile-host host) - (save-some-buffers nil nil) - (compilation-start compile-command) - ;; Set comint-file-name-prefix in the compilation buffer so - ;; compilation-parse-errors will find referenced files by Tramp. - (with-current-buffer compilation-last-buffer - (when (fboundp 'tramp-make-tramp-file-name) - (set (make-local-variable 'comint-file-name-prefix) - (tramp-make-tramp-file-name - nil ;; method. - remote-compile-user - remote-compile-host - "")))))) - -;;; rcompile.el ends here diff --git a/lisp/net/rfc2104.el b/lisp/net/rfc2104.el new file mode 100644 index 00000000000..f80e2287879 --- /dev/null +++ b/lisp/net/rfc2104.el @@ -0,0 +1,124 @@ +;;; rfc2104.el --- RFC2104 Hashed Message Authentication Codes + +;; Copyright (C) 1998-2015 Free Software Foundation, Inc. + +;; Author: Simon Josefsson <jas@pdc.kth.se> +;; Keywords: mail + +;; 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: + +;; This is a high performance implementation of RFC2104. +;; +;; Example: +;; +;; (require 'md5) +;; (rfc2104-hash 'md5 64 16 "Jefe" "what do ya want for nothing?") +;; "750c783e6ab0b503eaa86e310a5db738" +;; +;; (require 'sha1) +;; (rfc2104-hash 'sha1 64 20 "Jefe" "what do ya want for nothing?") +;; "effcdf6ae5eb2fa2d27416d5f184df9c259a7c79" +;; +;; 64 is block length of hash function (64 for MD5 and SHA), 16 is +;; resulting hash length (16 for MD5, 20 for SHA). +;; +;; Tested with Emacs 20.2 and XEmacs 20.3. +;; +;; Test case reference: RFC 2202. + +;;; History: + +;; 1998-08-16 initial release posted to gnu.emacs.sources +;; 1998-08-17 use append instead of char-list-to-string +;; 1998-08-26 don't require hexl +;; 1998-09-25 renamed from hmac.el to rfc2104.el, also renamed functions +;; 1999-10-23 included in pgnus +;; 2000-08-15 `rfc2104-hexstring-to-bitstring' +;; 2000-05-12 added sha-1 example, added test case reference +;; 2003-11-13 change rfc2104-hexstring-to-bitstring to ...-byte-list +;; 2008-04-25 rewrite rfc2104-hash for speed + +;;; Code: + +(eval-when-compile (require 'cl)) + +;; Magic character for inner HMAC round. 0x36 == 54 == '6' +(defconst rfc2104-ipad ?\x36) + +;; Magic character for outer HMAC round. 0x5C == 92 == '\' +(defconst rfc2104-opad ?\x5C) + +(defconst rfc2104-nybbles + (let ((v (make-vector + ;; Find upper bound to save some space. + (1+ (max ?0 ?9 ?a ?f ?A ?F)) + ;; Use non-numeric default to catch bogus hex strings. + nil)) + (ls '((?0 . 0) (?a . 10) (?A . 10) + (?1 . 1) (?b . 11) (?B . 11) + (?2 . 2) (?c . 12) (?C . 12) + (?3 . 3) (?d . 13) (?D . 13) + (?4 . 4) (?e . 14) (?E . 14) + (?5 . 5) (?f . 15) (?F . 15) + (?6 . 6) + (?7 . 7) + (?8 . 8) + (?9 . 9)))) + (while ls + (aset v (caar ls) (cdar ls)) + (setq ls (cdr ls))) + v)) + +(eval-when-compile + (defmacro rfc2104-string-make-unibyte (string) + "Return the unibyte equivalent of STRING. +In XEmacs return just STRING." + (if (featurep 'xemacs) + string + `(string-make-unibyte ,string)))) + +(defun rfc2104-hash (hash block-length hash-length key text) + (let* (;; if key is longer than B, reset it to HASH(key) + (key (if (> (length key) block-length) + (funcall hash key) key)) + (len (length key)) + (ipad (make-string block-length rfc2104-ipad)) + (opad (make-string (+ block-length hash-length) rfc2104-opad)) + c partial) + ;; Prefix *pad with key, appropriately XORed. + (do ((i 0 (1+ i))) + ((= len i)) + (setq c (aref key i)) + (aset ipad i (logxor rfc2104-ipad c)) + (aset opad i (logxor rfc2104-opad c))) + ;; Perform inner hash. + (setq partial (rfc2104-string-make-unibyte + (funcall hash (concat ipad text)))) + ;; Pack latter part of opad. + (do ((r 0 (+ 2 r)) + (w block-length (1+ w))) + ((= (* 2 hash-length) r)) + (aset opad w + (+ (* 16 (aref rfc2104-nybbles (aref partial r))) + ( aref rfc2104-nybbles (aref partial (1+ r)))))) + ;; Perform outer hash. + (rfc2104-string-make-unibyte (funcall hash opad)))) + +(provide 'rfc2104) + +;;; rfc2104.el ends here diff --git a/lisp/net/rlogin.el b/lisp/net/rlogin.el index e8d13254557..fead60eb8ab 100644 --- a/lisp/net/rlogin.el +++ b/lisp/net/rlogin.el @@ -1,6 +1,6 @@ ;;; rlogin.el --- remote login interface -;; Copyright (C) 1992-1995, 1997-1998, 2001-2013 Free Software +;; Copyright (C) 1992-1995, 1997-1998, 2001-2015 Free Software ;; Foundation, Inc. ;; Author: Noah Friedman @@ -145,7 +145,7 @@ other arguments for `rlogin'. Input is sent line-at-a-time to the remote connection. Communication with the remote host is recorded in a buffer `*rlogin-HOST*' -\(or `*rlogin-USER@HOST*' if the remote username differs\). +\(or `*rlogin-USER@HOST*' if the remote username differs). If a prefix argument is given and the buffer `*rlogin-HOST*' already exists, a new buffer with a different connection will be made. @@ -174,7 +174,7 @@ If you wish to change directory tracking styles during a session, use the function `rlogin-directory-tracking-mode' rather than simply setting the variable." (interactive (list - (read-from-minibuffer (format + (read-from-minibuffer (format-message "Arguments for `%s' (hostname first): " (file-name-nondirectory rlogin-program)) nil nil nil 'rlogin-history) @@ -235,14 +235,14 @@ variable." "Do remote or local directory tracking, or disable entirely. If called with no prefix argument or a unspecified prefix argument (just -``\\[universal-argument]'' with no number) do remote directory tracking via +`\\[universal-argument]' with no number) do remote directory tracking via ange-ftp. If called as a function, give it no argument. If called with a negative prefix argument, disable directory tracking entirely. If called with a positive, numeric prefix argument, e.g. -``\\[universal-argument] 1 M-x rlogin-directory-tracking-mode\'', +`\\[universal-argument] 1 M-x rlogin-directory-tracking-mode', then do directory tracking but assume the remote filesystem is the same as the local system. This only works in general if the remote machine and the local one share the same directories (e.g. through NFS)." diff --git a/lisp/net/sasl-cram.el b/lisp/net/sasl-cram.el index 2a132a5fcd9..235159497ab 100644 --- a/lisp/net/sasl-cram.el +++ b/lisp/net/sasl-cram.el @@ -1,6 +1,6 @@ ;;; sasl-cram.el --- CRAM-MD5 module for the SASL client framework -;; Copyright (C) 2000, 2007-2013 Free Software Foundation, Inc. +;; Copyright (C) 2000, 2007-2015 Free Software Foundation, Inc. ;; Author: Daiki Ueno <ueno@unixuser.org> ;; Kenichi OKADA <okada@opaopa.org> diff --git a/lisp/net/sasl-digest.el b/lisp/net/sasl-digest.el index 6adbf444a9e..aa3843bb386 100644 --- a/lisp/net/sasl-digest.el +++ b/lisp/net/sasl-digest.el @@ -1,6 +1,6 @@ ;;; sasl-digest.el --- DIGEST-MD5 module for the SASL client framework -;; Copyright (C) 2000, 2007-2013 Free Software Foundation, Inc. +;; Copyright (C) 2000, 2007-2015 Free Software Foundation, Inc. ;; Author: Daiki Ueno <ueno@unixuser.org> ;; Kenichi OKADA <okada@opaopa.org> diff --git a/lisp/net/sasl-ntlm.el b/lisp/net/sasl-ntlm.el index 487a1d03538..cab899e8ff9 100644 --- a/lisp/net/sasl-ntlm.el +++ b/lisp/net/sasl-ntlm.el @@ -1,6 +1,6 @@ ;;; sasl-ntlm.el --- NTLM (NT Lan Manager) module for the SASL client framework -;; Copyright (C) 2000, 2007-2013 Free Software Foundation, Inc. +;; Copyright (C) 2000, 2007-2015 Free Software Foundation, Inc. ;; Author: Taro Kawagishi <tarok@transpulse.org> ;; Keywords: SASL, NTLM diff --git a/lisp/net/sasl-scram-rfc.el b/lisp/net/sasl-scram-rfc.el new file mode 100644 index 00000000000..18d7a6bfa18 --- /dev/null +++ b/lisp/net/sasl-scram-rfc.el @@ -0,0 +1,163 @@ +;;; sasl-scram-rfc.el --- SCRAM-SHA-1 module for the SASL client framework -*- lexical-binding: t; -*- + +;; Copyright (C) 2014-2015 Free Software Foundation, Inc. + +;; Author: Magnus Henoch <magnus.henoch@gmail.com> + +;; 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: + +;; This program is implemented from RFC 5802. It implements the +;; SCRAM-SHA-1 SASL mechanism. +;; +;; RFC 5802 foresees "hash agility", i.e. new mechanisms based on the +;; same protocol but using a different hash function. Likewise, this +;; module attempts to separate generic and specific functions, which +;; should make it easy to implement any future SCRAM-* SASL mechanism. +;; It should be as simple as copying the SCRAM-SHA-1 section below and +;; replacing all SHA-1 references. +;; +;; This module does not yet implement the variants with channel +;; binding, i.e. SCRAM-*-PLUS. That would require cooperation from +;; the TLS library. + +;;; Code: + +(require 'cl-lib) +(require 'sasl) +(require 'hex-util) +(require 'rfc2104) + +;;; Generic for SCRAM-* + +(defun sasl-scram-client-first-message (client _step) + (let ((c-nonce (sasl-unique-id))) + (sasl-client-set-property client 'c-nonce c-nonce)) + (concat + ;; n = client doesn't support channel binding + "n," + ;; TODO: where would we get authorization id from? + "," + (sasl-scram--client-first-message-bare client))) + +(defun sasl-scram--client-first-message-bare (client) + (let ((c-nonce (sasl-client-property client 'c-nonce))) + (concat + ;; TODO: saslprep username or disallow non-ASCII characters + "n=" (sasl-client-name client) "," + "r=" c-nonce))) + +(defun sasl-scram--client-final-message (hash-fun block-length hash-length client step) + (unless (string-match + "^r=\\([^,]+\\),s=\\([^,]+\\),i=\\([0-9]+\\)\\(?:$\\|,\\)" + (sasl-step-data step)) + (sasl-error "Unexpected server response")) + (let* ((hmac-fun (lambda (text key) + (decode-hex-string + (rfc2104-hash hash-fun block-length hash-length key text)))) + (step-data (sasl-step-data step)) + (nonce (match-string 1 step-data)) + (salt-base64 (match-string 2 step-data)) + (iteration-count (string-to-number (match-string 3 step-data))) + + (c-nonce (sasl-client-property client 'c-nonce)) + ;; no channel binding, no authorization id + (cbind-input "n,,")) + (unless (string-prefix-p c-nonce nonce) + (sasl-error "Invalid nonce from server")) + (let* ((client-final-message-without-proof + (concat "c=" (base64-encode-string cbind-input) "," + "r=" nonce)) + (password + ;; TODO: either apply saslprep or disallow non-ASCII characters + (sasl-read-passphrase + (format "%s passphrase for %s: " + (sasl-mechanism-name (sasl-client-mechanism client)) + (sasl-client-name client)))) + (salt (base64-decode-string salt-base64)) + (salted-password + ;; Hi(str, salt, i): + (let ((digest (concat salt (string 0 0 0 1))) + (xored nil)) + (dotimes (_i iteration-count xored) + (setq digest (funcall hmac-fun digest password)) + (setq xored (if (null xored) + digest + (cl-map 'string 'logxor xored digest)))))) + (client-key + (funcall hmac-fun "Client Key" salted-password)) + (stored-key (decode-hex-string (funcall hash-fun client-key))) + (auth-message + (concat + (sasl-scram--client-first-message-bare client) "," + step-data "," + client-final-message-without-proof)) + (client-signature (funcall hmac-fun (encode-coding-string auth-message 'utf-8) stored-key)) + (client-proof (cl-map 'string 'logxor client-key client-signature)) + (client-final-message + (concat client-final-message-without-proof "," + "p=" (base64-encode-string client-proof)))) + (sasl-client-set-property client 'auth-message auth-message) + (sasl-client-set-property client 'salted-password salted-password) + client-final-message))) + +(defun sasl-scram--authenticate-server (hash-fun block-length hash-length client step) + (cond + ((string-match "^e=\\([^,]+\\)" (sasl-step-data step)) + (sasl-error (format "Server error: %s" (match-string 1 (sasl-step-data step))))) + ((string-match "^v=\\([^,]+\\)" (sasl-step-data step)) + (let* ((hmac-fun (lambda (text key) + (decode-hex-string + (rfc2104-hash hash-fun block-length hash-length key text)))) + (verifier (base64-decode-string (match-string 1 (sasl-step-data step)))) + (auth-message (sasl-client-property client 'auth-message)) + (salted-password (sasl-client-property client 'salted-password)) + (server-key (funcall hmac-fun "Server Key" salted-password)) + (expected-server-signature + (funcall hmac-fun (encode-coding-string auth-message 'utf-8) server-key))) + (unless (string= expected-server-signature verifier) + (sasl-error "Server not authenticated")))) + (t + (sasl-error "Invalid response from server")))) + +;;; SCRAM-SHA-1 + +(defconst sasl-scram-sha-1-steps + '(sasl-scram-client-first-message + sasl-scram-sha-1-client-final-message + sasl-scram-sha-1-authenticate-server)) + +(defun sasl-scram-sha-1-client-final-message (client step) + (sasl-scram--client-final-message + ;; HMAC-SHA1 uses block length 64 and hash length 20; see RFC 2104. + 'sha1 64 20 client step)) + +(defun sasl-scram-sha-1-authenticate-server (client step) + (sasl-scram--authenticate-server + 'sha1 64 20 client step)) + +;; This needs to be at the end, because of how `sasl-make-mechanism' +;; handles step function names. +(put 'sasl-scram-sha-1 'sasl-mechanism + (sasl-make-mechanism "SCRAM-SHA-1" sasl-scram-sha-1-steps)) + +(put 'sasl-scram-rfc 'sasl-mechanism (get 'sasl-scram-sha-1 'sasl-mechanism)) + +(provide 'sasl-scram-sha-1) + +(provide 'sasl-scram-rfc) +;;; sasl-scram-rfc.el ends here diff --git a/lisp/net/sasl.el b/lisp/net/sasl.el index a5efdd620e9..9321efdfda8 100644 --- a/lisp/net/sasl.el +++ b/lisp/net/sasl.el @@ -1,6 +1,6 @@ ;;; sasl.el --- SASL client framework -;; Copyright (C) 2000, 2007-2013 Free Software Foundation, Inc. +;; Copyright (C) 2000, 2007-2015 Free Software Foundation, Inc. ;; Author: Daiki Ueno <ueno@unixuser.org> ;; Keywords: SASL @@ -35,8 +35,8 @@ ;;; Code: (defvar sasl-mechanisms - '("CRAM-MD5" "DIGEST-MD5" "PLAIN" "LOGIN" "ANONYMOUS" - "NTLM" "SCRAM-MD5")) + '("SCRAM-SHA-1" "CRAM-MD5" "DIGEST-MD5" "PLAIN" "LOGIN" "ANONYMOUS" + "NTLM")) (defvar sasl-mechanism-alist '(("CRAM-MD5" sasl-cram) @@ -45,7 +45,7 @@ ("LOGIN" sasl-login) ("ANONYMOUS" sasl-anonymous) ("NTLM" sasl-ntlm) - ("SCRAM-MD5" sasl-scram))) + ("SCRAM-SHA-1" sasl-scram-rfc))) (defvar sasl-unique-id-function #'sasl-unique-id-function) diff --git a/lisp/net/secrets.el b/lisp/net/secrets.el index b4e51348dde..5e0274029f1 100644 --- a/lisp/net/secrets.el +++ b/lisp/net/secrets.el @@ -1,6 +1,6 @@ ;;; secrets.el --- Client interface to gnome-keyring and kwallet. -;; Copyright (C) 2010-2013 Free Software Foundation, Inc. +;; Copyright (C) 2010-2015 Free Software Foundation, Inc. ;; Author: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm password passphrase @@ -85,7 +85,7 @@ ;; temporarily. This shall be preferred over creation of a persistent ;; collection, when the information shall not live longer than Emacs. ;; The session collection can be addressed either by the string -;; "session", or by `nil', whenever a collection parameter is needed. +;; "session", or by nil, whenever a collection parameter is needed. ;; As already said, a collection is a group of secret items. A secret ;; item has a label, the "secret" (which is a string), and a set of @@ -189,6 +189,7 @@ It returns t if not." ;; </method> ;; <method name="CreateCollection"> ;; <arg name="props" type="a{sv}" direction="in"/> +;; <arg name="alias" type="s" direction="in"/> ;; Added 2011/3/1 ;; <arg name="collection" type="o" direction="out"/> ;; <arg name="prompt" type="o" direction="out"/> ;; </method> @@ -417,7 +418,7 @@ returned, and it will be stored in `secrets-session-path'." (defun secrets-prompt-handler (&rest args) "Handler for signals emitted by `secrets-interface-prompt'." ;; An empty object path is always identified as `secrets-empty-path' - ;; or `nil'. Either we set it explicitly, or it is returned by the + ;; or nil. Either we set it explicitly, or it is returned by the ;; "Completed" signal. (if (car args) ;; dismissed (setq secrets-prompt-signal (list secrets-empty-path)) @@ -491,9 +492,10 @@ If there is no such COLLECTION, return nil." (secrets-get-collection-property collection-path "Label")) (throw 'collection-found collection-path)))))) -(defun secrets-create-collection (collection) +(defun secrets-create-collection (collection &optional alias) "Create collection labeled COLLECTION if it doesn't exist. -Return the D-Bus object path for collection." +Set ALIAS as alias of the collection. Return the D-Bus object +path for collection." (let ((collection-path (secrets-collection-path collection))) ;; Create the collection. (when (secrets-empty-path collection-path) @@ -504,7 +506,10 @@ Return the D-Bus object path for collection." (dbus-call-method :session secrets-service secrets-path secrets-interface-service "CreateCollection" - `(:array (:dict-entry "Label" (:variant ,collection)))))))) + `(:array + (:dict-entry ,(concat secrets-interface-collection ".Label") + (:variant ,collection))) + (or alias "")))))) ;; Return object path of the collection. collection-path)) @@ -593,10 +598,9 @@ If successful, return the object path of the collection." ATTRIBUTES are key-value pairs. The keys are keyword symbols, starting with a colon. Example: - \(secrets-create-item \"Tramp collection\" \"item\" \"geheim\" - :method \"sudo\" :user \"joe\" :host \"remote-host\"\) + (secrets-search-items \"Tramp collection\" :user \"joe\") -The object paths of the found items are returned as list." +The object labels of the found items are returned as list." (let ((collection-path (secrets-unlock-collection collection)) result props) (unless (secrets-empty-path collection-path) @@ -604,6 +608,8 @@ The object paths of the found items are returned as list." (while (consp (cdr attributes)) (unless (keywordp (car attributes)) (error 'wrong-type-argument (car attributes))) + (unless (stringp (cadr attributes)) + (error 'wrong-type-argument (cadr attributes))) (setq props (add-to-list 'props (list :dict-entry @@ -611,8 +617,7 @@ The object paths of the found items are returned as list." (cadr attributes)) 'append) attributes (cddr attributes))) - ;; Search. The result is a list of two lists, the object paths - ;; of the unlocked and the locked items. + ;; Search. The result is a list of object paths. (setq result (dbus-call-method :session secrets-service collection-path @@ -623,15 +628,15 @@ The object paths of the found items are returned as list." ;; Return the found items. (mapcar (lambda (item-path) (secrets-get-item-property item-path "Label")) - (append (car result) (cadr result)))))) + result)))) (defun secrets-create-item (collection item password &rest attributes) "Create a new item in COLLECTION with label ITEM and password PASSWORD. ATTRIBUTES are key-value pairs set for the created item. The keys are keyword symbols, starting with a colon. Example: - \(secrets-create-item \"Tramp collection\" \"item\" \"geheim\" - :method \"sudo\" :user \"joe\" :host \"remote-host\"\) + (secrets-create-item \"Tramp collection\" \"item\" \"geheim\" + :method \"sudo\" :user \"joe\" :host \"remote-host\") The object path of the created item is returned." (unless (member item (secrets-list-items collection)) @@ -642,6 +647,8 @@ The object path of the created item is returned." (while (consp (cdr attributes)) (unless (keywordp (car attributes)) (error 'wrong-type-argument (car attributes))) + (unless (stringp (cadr attributes)) + (error 'wrong-type-argument (cadr attributes))) (setq props (add-to-list 'props (list :dict-entry @@ -693,7 +700,7 @@ If there is no such item, return nil." (let ((item-path (secrets-item-path collection item))) (unless (secrets-empty-path item-path) (dbus-byte-array-to-string - (cl-caddr + (nth 2 (dbus-call-method :session secrets-service item-path secrets-interface-item "GetSecret" :object-path secrets-session-path)))))) diff --git a/lisp/net/shr-color.el b/lisp/net/shr-color.el index 21f1fc4f004..f8d358c27b3 100644 --- a/lisp/net/shr-color.el +++ b/lisp/net/shr-color.el @@ -1,6 +1,6 @@ ;;; shr-color.el --- Simple HTML Renderer color management -;; Copyright (C) 2010-2013 Free Software Foundation, Inc. +;; Copyright (C) 2010-2015 Free Software Foundation, Inc. ;; Author: Julien Danjou <julien@danjou.info> ;; Keywords: html @@ -211,7 +211,7 @@ This will convert \"80 %\" to 204, \"100 %\" to 255 but \"123\" to \"123\"." "Convert X Y H to RGB value." (when (< h 0) (incf h)) (when (> h 1) (decf h)) - (cond ((< h (/ 1 6.0)) (+ x (* (- y x) h 6))) + (cond ((< h (/ 6.0)) (+ x (* (- y x) h 6))) ((< h 0.5) y) ((< h (/ 2.0 3.0)) (+ x (* (- y x) (- (/ 2.0 3.0) h) 6))) (t x))) @@ -223,9 +223,9 @@ This will convert \"80 %\" to 204, \"100 %\" to 255 but \"123\" to \"123\"." (setq m2 (* l (+ s 1))) (setq m2 (- (+ l s) (* l s)))) (setq m1 (- (* l 2) m2)) - (list (shr-color-hue-to-rgb m1 m2 (+ h (/ 1 3.0))) + (list (shr-color-hue-to-rgb m1 m2 (+ h (/ 3.0))) (shr-color-hue-to-rgb m1 m2 h) - (shr-color-hue-to-rgb m1 m2 (- h (/ 1 3.0)))))) + (shr-color-hue-to-rgb m1 m2 (- h (/ 3.0)))))) (defun shr-color->hexadecimal (color) "Convert any color format to hexadecimal representation. @@ -242,7 +242,7 @@ Like rgb() or hsl()." "rgb(\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*)" color) (string-match - "rgba(\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*[0-9]*\.?[0-9]+\s*%?\s*)" + "rgba(\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*\\([0-9]\\{1,3\\}\\(?:\s*%\\)?\\)\s*,\s*[0-9]*\\.?[0-9]+\s*%?\s*)" color)) (format "#%02X%02X%02X" (shr-color-relative-to-absolute (match-string-no-properties 1 color)) @@ -253,7 +253,7 @@ Like rgb() or hsl()." "hsl(\s*\\([0-9]\\{1,3\\}\\)\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*)" color) (string-match - "hsla(\s*\\([0-9]\\{1,3\\}\\)\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*[0-9]*\.?[0-9]+\s*%?\s*)" + "hsla(\s*\\([0-9]\\{1,3\\}\\)\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*\\([0-9]\\{1,3\\}\\)\s*%\s*,\s*[0-9]*\\.?[0-9]+\s*%?\s*)" color)) (let ((h (/ (string-to-number (match-string-no-properties 1 color)) 360.0)) (s (/ (string-to-number (match-string-no-properties 2 color)) 100.0)) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 9cac618b159..58deaea6f53 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -1,6 +1,6 @@ ;;; shr.el --- Simple HTML Renderer -;; Copyright (C) 2010-2013 Free Software Foundation, Inc. +;; Copyright (C) 2010-2015 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: html @@ -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. @@ -55,6 +57,12 @@ fit these criteria." :group 'shr :type '(choice (const nil) regexp)) +(defcustom shr-use-fonts t + "If non-nil, use proportional fonts for text." + :version "25.1" + :group 'shr + :type 'boolean) + (defcustom shr-table-horizontal-line nil "Character used to draw horizontal table lines. If nil, don't draw horizontal table lines." @@ -76,11 +84,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) @@ -90,6 +99,7 @@ used." Alternative suggestions are: - \" \" - \" \"" + :version "24.4" :type 'string :group 'shr) @@ -99,6 +109,12 @@ Alternative suggestions are: :group 'shr :type 'function) +(defcustom shr-image-animate t + "Non nil means that images that can be animated will be." + :version "24.4" + :group 'shr + :type 'boolean) + (defvar shr-content-function nil "If bound, this should be a function that will return the content. This is used for cid: URLs, and the function is called with the @@ -116,32 +132,39 @@ 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 nil) (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) -(defvar shr-inhibit-decoration nil) (defvar shr-table-separator-length 1) +(defvar shr-table-separator-pixel-width 0) +(defvar shr-table-id nil) +(defvar shr-current-font nil) +(defvar shr-internal-bullet nil) (defvar shr-map (let ((map (make-sparse-keymap))) (define-key map "a" 'shr-show-alt-text) (define-key map "i" 'shr-browse-image) (define-key map "z" 'shr-zoom-image) - (define-key map [tab] 'shr-next-link) - (define-key map [backtab] 'shr-previous-link) + (define-key map [?\t] 'shr-next-link) + (define-key map [?\M-\t] 'shr-previous-link) (define-key map [follow-link] 'mouse-face) (define-key map [mouse-2] 'shr-browse-url) (define-key map "I" 'shr-insert-image) @@ -154,7 +177,7 @@ cid: URL as the argument.") ;; Public functions and commands. (declare-function libxml-parse-html-region "xml.c" - (start end &optional base-url)) + (start end &optional base-url discard-comments)) (defun shr-render-buffer (buffer) "Display the HTML rendering of the current buffer." @@ -168,6 +191,7 @@ cid: URL as the argument.") (libxml-parse-html-region (point-min) (point-max)))) (goto-char (point-min))) +;;;###autoload (defun shr-render-region (begin end &optional buffer) "Display the HTML rendering of the region between BEGIN and END." (interactive "r") @@ -179,13 +203,6 @@ cid: URL as the argument.") (goto-char begin) (shr-insert-document dom)))) -(defun shr-visit-file (file) - "Parse FILE as an HTML document, and render it in a new buffer." - (interactive "fHTML file name: ") - (with-temp-buffer - (insert-file-contents file) - (shr-render-buffer (current-buffer)))) - ;;;###autoload (defun shr-insert-document (dom) "Render the parsed document DOM into the current buffer. @@ -193,13 +210,46 @@ DOM should be a parse tree as generated by `libxml-parse-html-region' or similar." (setq shr-content-cache nil) (let ((start (point)) - (shr-state nil) (shr-start nil) (shr-base nil) - (shr-preliminary-table-render 0) - (shr-width (or shr-width (1- (window-width))))) - (shr-descend (shr-transform-dom dom)) - (shr-remove-trailing-whitespace start (point)))) + (shr-depth 0) + (shr-table-id 0) + (shr-warning nil) + (shr-table-separator-pixel-width (shr-string-pixel-width "-")) + (shr-internal-bullet (cons shr-bullet + (shr-string-pixel-width shr-bullet))) + (shr-internal-width (or (and shr-width + (if (not shr-use-fonts) + shr-width + (* shr-width (frame-char-width)))) + ;; We need to adjust the available + ;; width for when the user disables + ;; the fringes, which will cause the + ;; display engine usurp one column for + ;; the continuation glyph. + (if (not shr-use-fonts) + (- (window-body-width) 1 + (if (and (null shr-width) + (or (zerop + (fringe-columns 'right)) + (zerop + (fringe-columns 'left)))) + 0 + 1)) + (- (window-body-width nil t) + (* 2 (frame-char-width)) + (if (and (null shr-width) + (or (zerop + (fringe-columns 'right)) + (zerop + (fringe-columns 'left)))) + (* (frame-char-width) 2) + 0)))))) + (shr-descend dom) + (shr-fill-lines start (point)) + (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 +264,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 +296,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 +341,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-fill-text text))))) (defun shr-browse-image (&optional copy-url) "Browse the image under point. @@ -353,184 +408,274 @@ 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 (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)) - (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))))))) - -(defun shr-generic (cont) - (dolist (sub cont) - (cond - ((eq (car sub) 'text) - (shr-insert (cdr sub))) - ((listp (cdr sub)) - (shr-descend sub))))) - -(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-fill-text (text) + (if (zerop (length text)) + text + (with-temp-buffer + (let ((shr-indentation 0) + (shr-start nil) + (shr-internal-width (- (window-body-width nil t) + (* 2 (frame-char-width)) + ;; Adjust the window width for when + ;; the user disables the fringes, + ;; which causes the display engine + ;; to usurp one column for the + ;; continuation glyph. + (if (and (null shr-width) + (or (zerop (fringe-columns 'right)) + (zerop (fringe-columns 'left)))) + (* (frame-char-width) 2) + 0)))) + (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." - `(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)) +(defun shr-pixel-column () + (if (not shr-use-fonts) + (current-column) + (if (not (get-buffer-window (current-buffer))) + (save-window-excursion + (set-window-buffer nil (current-buffer)) + (car (window-text-pixel-size nil (line-beginning-position) (point)))) + (car (window-text-pixel-size nil (line-beginning-position) (point)))))) + +(defun shr-pixel-region () + (- (shr-pixel-column) + (save-excursion + (goto-char (mark)) + (shr-pixel-column)))) + +(defun shr-string-pixel-width (string) + (if (not shr-use-fonts) + (length string) + (with-temp-buffer + (insert string) + (shr-pixel-column)))) + (defun shr-insert (text) - (when (and (eq shr-state 'image) - (not (bolp)) - (not (string-match "\\`[ \t\n]+\\'" text))) - (insert "\n") - (setq shr-state nil)) + (when (and (not (bolp)) + (get-text-property (1- (point)) 'image-url)) + (insert "\n")) (cond ((eq shr-folding-mode 'none) - (insert text)) + (let ((start (point))) + (insert text) + (save-restriction + (narrow-to-region start (point)) + ;; Remove soft hyphens. + (goto-char (point-min)) + (while (search-forward "" nil t) + (replace-match "" t t)) + (goto-char (point-max))))) (t - (when (and (string-match "\\`[ \t\n ]" text) - (not (bolp)) - (not (eq (char-after (1- (point))) ? ))) - (insert " ")) - (dolist (elem (split-string text "[ \f\t\n\r\v ]+" t)) - (when (and (bolp) - (> shr-indentation 0)) - (shr-indent)) - ;; No space is needed behind a wide character categorized as - ;; kinsoku-bol, between characters both categorized as nospace, - ;; or at the beginning of a line. - (let (prev) - (when (and (> (current-column) shr-indentation) - (eq (preceding-char) ? ) - (or (= (line-beginning-position) (1- (point))) - (and (shr-char-breakable-p - (setq prev (char-after (- (point) 2)))) - (shr-char-kinsoku-bol-p prev)) - (and (shr-char-nospace-p prev) - (shr-char-nospace-p (aref elem 0))))) - (delete-char -1))) - ;; The shr-start is a special variable that is used to pass - ;; upwards the first point in the buffer where the text really - ;; starts. - (unless shr-start - (setq shr-start (point))) - (insert elem) - (setq shr-state nil) - (let (found) - (while (and (> (current-column) shr-width) - (progn - (setq found (shr-find-fill-point)) - (not (eolp)))) - (when (eq (preceding-char) ? ) - (delete-char -1)) - (insert "\n") - (unless found - ;; No space is needed at the beginning of a line. - (when (eq (following-char) ? ) - (delete-char 1))) - (when (> shr-indentation 0) - (shr-indent)) - (end-of-line)) - (insert " "))) - (unless (string-match "[ \t\r\n ]\\'" text) - (delete-char -1))))) - -(defun shr-find-fill-point () - (when (> (move-to-column shr-width) shr-width) - (backward-char 1)) + (let ((font-start (point))) + (when (and (string-match "\\`[ \t\n\r ]" text) + (not (bolp)) + (not (eq (char-after (1- (point))) ? ))) + (insert " ")) + (let ((start (point)) + (bolp (bolp))) + (insert text) + (save-restriction + (narrow-to-region start (point)) + (goto-char start) + (when (looking-at "[ \t\n\r ]+") + (replace-match "" t t)) + (while (re-search-forward "[ \t\n\r ]+" nil t) + (replace-match " " t t)) + ;; Remove soft hyphens. + (goto-char (point-min)) + (while (search-forward "" nil t) + (replace-match "" t t)) + (goto-char (point-max))) + ;; We may have removed everything we inserted if if was just + ;; spaces. + (unless (= font-start (point)) + ;; Mark all lines that should possibly be folded afterwards. + (when bolp + (shr-mark-fill start)) + (when shr-use-fonts + (put-text-property font-start (point) + 'face + (or shr-current-font 'variable-pitch))))))))) + +(defun shr-fill-lines (start end) + (if (<= shr-internal-width 0) + nil + (save-restriction + (narrow-to-region start end) + (goto-char start) + (when (get-text-property (point) 'shr-indentation) + (shr-fill-line)) + (while (setq start (next-single-property-change start 'shr-indentation)) + (goto-char start) + (when (bolp) + (shr-fill-line))) + (goto-char (point-max))))) + +(defun shr-vertical-motion (column) + (if (not shr-use-fonts) + (move-to-column column) + (unless (eolp) + (forward-char 1)) + (vertical-motion (cons (/ column (frame-char-width)) 0)) + (unless (eolp) + (forward-char 1)))) + +(defun shr-fill-line () + (let ((shr-indentation (get-text-property (point) 'shr-indentation)) + (continuation (get-text-property + (point) 'shr-continuation-indentation)) + start) + (put-text-property (point) (1+ (point)) 'shr-indentation nil) + (let ((face (get-text-property (point) 'face)) + (background-start (point))) + (shr-indent) + (when face + (put-text-property background-start (point) 'face + `,(shr-face-background face)))) + (setq start (point)) + (setq shr-indentation (or continuation shr-indentation)) + (shr-vertical-motion shr-internal-width) + (when (looking-at " $") + (delete-region (point) (line-end-position))) + (while (not (eolp)) + ;; We have to do some folding. First find the first + ;; previous point suitable for folding. + (if (or (not (shr-find-fill-point (line-beginning-position))) + (= (point) start)) + ;; We had unbreakable text (for this width), so just go to + ;; the first space and carry on. + (progn + (beginning-of-line) + (skip-chars-forward " ") + (search-forward " " (line-end-position) 'move))) + ;; Success; continue. + (when (= (preceding-char) ?\s) + (delete-char -1)) + (let ((face (get-text-property (point) 'face)) + (background-start (point))) + (insert "\n") + (shr-indent) + (when face + (put-text-property background-start (point) 'face + `,(shr-face-background face)))) + (setq start (point)) + (shr-vertical-motion shr-internal-width) + (when (looking-at " $") + (delete-region (point) (line-end-position)))))) + +(defun shr-find-fill-point (start) (let ((bp (point)) + (end (point)) failed) - (while (not (or (setq failed (= (current-column) shr-indentation)) + (while (not (or (setq failed (<= (point) start)) (eq (preceding-char) ? ) (eq (following-char) ? ) (shr-char-breakable-p (preceding-char)) (shr-char-breakable-p (following-char)) - (if (eq (preceding-char) ?') - (not (memq (char-after (- (point) 2)) - (list nil ?\n ? ))) - (and (shr-char-kinsoku-bol-p (preceding-char)) - (shr-char-breakable-p (following-char)) - (not (shr-char-kinsoku-bol-p (following-char))))) - (shr-char-kinsoku-eol-p (following-char)))) + (and (shr-char-kinsoku-bol-p (preceding-char)) + (shr-char-breakable-p (following-char)) + (not (shr-char-kinsoku-bol-p (following-char)))) + (shr-char-kinsoku-eol-p (following-char)) + (bolp))) (backward-char 1)) - (if (and (not (or failed (eolp))) - (eq (preceding-char) ?')) - (while (not (or (setq failed (eolp)) - (eq (following-char) ? ) - (shr-char-breakable-p (following-char)) - (shr-char-kinsoku-eol-p (following-char)))) - (forward-char 1))) (if failed ;; There's no breakable point, so we give it up. (let (found) (goto-char bp) - (unless shr-kinsoku-shorten - (while (and (setq found (re-search-forward - "\\(\\c>\\)\\| \\|\\c<\\|\\c|" - (line-end-position) 'move)) - (eq (preceding-char) ?'))) - (if (and found (not (match-beginning 1))) + ;; Don't overflow the window edge, even if + ;; shr-kinsoku-shorten is nil. + (unless (or shr-kinsoku-shorten (null shr-width)) + (while (setq found (re-search-forward + "\\(\\c>\\)\\| \\|\\c<\\|\\c|" + (line-end-position) 'move))) + (if (and found + (not (match-beginning 1))) (goto-char (match-beginning 0))))) (or (eolp) ;; Don't put kinsoku-bol characters at the beginning of a line, ;; or kinsoku-eol characters at the end of a line. (cond - (shr-kinsoku-shorten + ;; Don't overflow the window edge, even if shr-kinsoku-shorten + ;; is nil. + ((or shr-kinsoku-shorten (null shr-width)) (while (and (not (memq (preceding-char) (list ?\C-@ ?\n ? ))) - (shr-char-kinsoku-eol-p (preceding-char))) + (or (shr-char-kinsoku-eol-p (preceding-char)) + (shr-char-kinsoku-bol-p (following-char)))) (backward-char 1)) - (when (setq failed (= (current-column) shr-indentation)) + (when (setq failed (<= (point) start)) ;; There's no breakable point that doesn't violate kinsoku, ;; so we look for the second best position. (while (and (progn (forward-char 1) - (<= (current-column) shr-width)) + (<= (point) end)) (progn (setq bp (point)) (shr-char-kinsoku-eol-p (following-char))))) @@ -545,12 +690,12 @@ size, and full-buffer size." (not (memq (preceding-char) (list ?\C-@ ?\n ? ))) (or (shr-char-kinsoku-eol-p (preceding-char)) (shr-char-kinsoku-bol-p (following-char))))))) - (if (setq failed (= (current-column) shr-indentation)) - ;; There's no breakable point that doesn't violate kinsoku, - ;; so we go to the second best position. - (if (looking-at "\\(\\c<+\\)\\c<") - (goto-char (match-end 1)) - (forward-char 1)))) + (when (setq failed (<= (point) start)) + ;; There's no breakable point that doesn't violate kinsoku, + ;; so we go to the second best position. + (if (looking-at "\\(\\c<+\\)\\c<") + (goto-char (match-end 1)) + (forward-char 1)))) ((shr-char-kinsoku-bol-p (following-char)) ;; Find forward the point where kinsoku-bol characters end. (let ((count 4)) @@ -567,6 +712,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) "") @@ -582,19 +729,27 @@ size, and full-buffer size." (url-type parsed) url))) +(autoload 'url-expand-file-name "url-expand") + +;; FIXME This needs some tests writing. +;; Does it even need to exist, given that url-expand-file-name does? (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)) (when (zerop (length url)) (setq url nil)) + ;; Strip leading whitespace + (and url (string-match "\\`\\s-+" url) + (setq url (substring url (match-end 0)))) (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) ?/)) @@ -607,7 +762,7 @@ size, and full-buffer size." (concat (nth 3 base) url)) (t ;; Totally relative. - (concat (car base) (cadr base) url)))) + (url-expand-file-name url (concat (car base) (cadr base)))))) (defun shr-ensure-newline () (unless (zerop (current-column)) @@ -615,48 +770,61 @@ size, and full-buffer size." (defun shr-ensure-paragraph () (unless (bobp) - (if (<= (current-column) shr-indentation) - (unless (save-excursion - (forward-line -1) - (looking-at " *$")) - (insert "\n")) - (if (save-excursion - (beginning-of-line) - ;; If the current line is totally blank, and doesn't even - ;; have any face properties set, then delete the blank - ;; space. - (and (looking-at " *$") - (not (get-text-property (point) 'face)) - (not (= (next-single-property-change (point) 'face nil - (line-end-position)) - (line-end-position))))) - (delete-region (match-beginning 0) (match-end 0)) - (insert "\n\n"))))) + (let ((prefix (get-text-property (line-beginning-position) + 'shr-prefix-length))) + (cond + ((and (bolp) + (save-excursion + (forward-line -1) + (looking-at " *$"))) + ;; We're already at a new paragraph; do nothing. + ) + ((and prefix + (= prefix (- (point) (line-beginning-position)))) + ;; Do nothing; we're at the start of a <li>. + ) + ((save-excursion + (beginning-of-line) + ;; If the current line is totally blank, and doesn't even + ;; have any face properties set, then delete the blank + ;; space. + (and (looking-at " *$") + (not (get-text-property (point) 'face)) + (not (= (next-single-property-change (point) 'face nil + (line-end-position)) + (line-end-position))))) + (delete-region (match-beginning 0) (match-end 0))) + (t + (insert "\n\n")))))) (defun shr-indent () (when (> shr-indentation 0) - (insert (make-string shr-indentation ? )))) - -(defun shr-fontize-cont (cont &rest types) - (let (shr-start) - (shr-generic cont) + (insert + (if (not shr-use-fonts) + (make-string shr-indentation ?\s) + (propertize " " + 'display + `(space :width (,shr-indentation))))))) + +(defun shr-fontize-dom (dom &rest types) + (let ((start (point))) + (shr-generic dom) (dolist (type types) - (shr-add-font (or shr-start (point)) (point) type)))) + (shr-add-font start (point) type)))) ;; Add face to the region, but avoid putting the font properties on ;; blank text at the start of the line, and the newline at the end, to ;; avoid ugliness. (defun shr-add-font (start end type) - (unless shr-inhibit-decoration - (save-excursion - (goto-char start) - (while (< (point) end) - (when (bolp) - (skip-chars-forward " ")) - (add-face-text-property (point) (min (line-end-position) end) type t) - (if (< (line-end-position) end) - (forward-line 1) - (goto-char end)))))) + (save-excursion + (goto-char start) + (while (< (point) end) + (when (bolp) + (skip-chars-forward " ")) + (add-face-text-property (point) (min (line-end-position) end) type t) + (if (< (line-end-position) end) + (forward-line 1) + (goto-char end))))) (defun shr-mouse-browse-url (ev) "Browse the URL under the mouse cursor." @@ -732,6 +900,10 @@ If EXTERNAL, browse the URL using `shr-external-browser'." (setq payload (base64-decode-string payload))) payload))) +;; Behind display-graphic-p test. +(declare-function image-size "image.c" (spec &optional pixels frame)) +(declare-function image-animate "image" (image &optional index limit)) + (defun shr-put-image (spec alt &optional flags) "Insert image SPEC with a string ALT. Return image. SPEC is either an image data blob, or a list where the first @@ -748,12 +920,14 @@ 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 t content-type))) + (shr-rescale-image data content-type))) (t (ignore-errors - (shr-rescale-image data nil content-type)))))) + (shr-rescale-image data content-type)))))) (when image ;; When inserting big-ish pictures, put them at the ;; beginning of the line. @@ -764,22 +938,22 @@ element is the data blob and the second element is the content-type." (insert-sliced-image image (or alt "*") nil 20 1) (insert-image image (or alt "*"))) (put-text-property start (point) 'image-size size) - (when (cond ((fboundp 'image-multi-frame-p) + (when (and shr-image-animate + (cond ((fboundp 'image-multi-frame-p) ;; Only animate multi-frame things that specify a ;; delay; eg animated gifs as opposed to ;; multi-page tiffs. FIXME? - (cdr (image-multi-frame-p image))) - ((fboundp 'image-animated-p) - (image-animated-p image))) - (image-animate image nil 60))) + (cdr (image-multi-frame-p image))) + ((fboundp 'image-animated-p) + (image-animated-p image)))) + (image-animate image nil 60))) image) (insert alt))) -(defun shr-rescale-image (data &optional force content-type) - "Rescale DATA, if too big, to fit the current buffer. -If FORCE, rescale the image anyway." - (if (or (not (fboundp 'imagemagick-types)) - (not (get-buffer-window (current-buffer)))) +(defun shr-rescale-image (data &optional content-type) + "Rescale DATA, if too big, to fit the current buffer." + (if (not (and (fboundp 'imagemagick-types) + (get-buffer-window (current-buffer)))) (create-image data nil t :ascent 100) (let ((edges (window-inside-pixel-edges (get-buffer-window (current-buffer))))) @@ -809,15 +983,28 @@ Return a string with image data." (search-forward "\r\n\r\n" nil t)) (shr-parse-image-data))))) +(declare-function libxml-parse-xml-region "xml.c" + (start end &optional base-url discard-comments)) + (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. @@ -839,18 +1026,22 @@ 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) - (when (and title (string-match "ctx" title)) (debug)) (shr-add-font start (point) 'shr-link) (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))) @@ -885,8 +1076,7 @@ ones, in case fg and bg are nil." (shr-color-visible bg fg))))))) (defun shr-colorize-region (start end fg &optional bg) - (when (and (not shr-inhibit-decoration) - (or fg bg)) + (when (and (or fg bg) (>= (display-color-cells) 88)) (let ((new-colors (shr-color-check fg bg))) (when new-colors (when fg @@ -899,44 +1089,6 @@ ones, in case fg and bg are nil." t))) new-colors))) -(defun shr-expand-newlines (start end color) - (save-restriction - ;; Skip past all white space at the start and ends. - (goto-char start) - (skip-chars-forward " \t\n") - (beginning-of-line) - (setq start (point)) - (goto-char end) - (skip-chars-backward " \t\n") - (forward-line 1) - (setq end (point)) - (narrow-to-region start end) - (let ((width (shr-buffer-width)) - column) - (goto-char (point-min)) - (while (not (eobp)) - (end-of-line) - (when (and (< (setq column (current-column)) width) - (< (setq column (shr-previous-newline-padding-width column)) - width)) - (let ((overlay (make-overlay (point) (1+ (point))))) - (overlay-put overlay 'before-string - (concat - (mapconcat - (lambda (overlay) - (let ((string (plist-get - (overlay-properties overlay) - 'before-string))) - (if (not string) - "" - (overlay-put overlay 'before-string "") - string))) - (overlays-at (point)) - "") - (propertize (make-string (- width column) ? ) - 'face (list :background color)))))) - (forward-line 1))))) - (defun shr-previous-newline-padding-width (width) (let ((overlays (overlays-at (point))) (previous-width 0)) @@ -951,97 +1103,108 @@ 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 "")) - (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)) - (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) - (when (image-type-available-p 'svg) - (funcall shr-put-image-function - (shr-dom-to-xml (cons 'svg cont)) - "SVG Image"))) - -(defun shr-tag-sup (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 (list (shr-dom-to-xml dom) 'image/svg+xml) + "SVG Image"))) + +(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-tag-tt (dom) + (let ((shr-current-font 'default)) + (shr-generic dom))) (defun shr-parse-style (style) (when style @@ -1058,63 +1221,145 @@ ones, in case fg and bg are nil." (value (replace-regexp-in-string "^ +\\| +$" "" (cadr elem)))) (when (string-match " *!important\\'" value) (setq value (substring value 0 (match-beginning 0)))) - (push (cons (intern name obarray) - value) - plist))))) + (unless (equal value "inherit") + (push (cons (intern name obarray) + value) + 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) - (when (and url - (not shr-inhibit-decoration)) + (shr-generic dom) + (when (and 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)) + (shr-ensure-newline) + (insert " ")) + (put-text-property start (1+ start) 'shr-target-id shr-target-id)) + (when url (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) + ("ogg" . 1.0) + ("opus" . 1.0) + ("flac" . 0.9) + ("wav" . 0.5)) + "Preferences for media types. +The key element should be a regexp matched against the type of the source or +url if no type is specified. The value should be a float in the range 0.0 to +1.0. Media elements with higher value are preferred." + :version "24.4" + :group 'shr + :type '(alist :key-type regexp :value-type float)) + +(defun shr--get-media-pref (elem) + "Determine the preference for ELEM. +The preference is a float determined from `shr-prefer-media-type'." + (let ((type (dom-attr elem 'type)) + (p 0.0)) + (unless type + (setq type (dom-attr elem 'src))) + (when type + (dolist (pref shr-prefer-media-type-alist) + (when (and + (> (cdr pref) p) + (string-match-p (car pref) type)) + (setq p (cdr pref))))) + p)) + +(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 (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 (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 (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 (dom) + (let ((image (dom-attr dom 'poster)) + (url (dom-attr dom 'src)) + (start (point))) + (unless url + (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-video (cont) - (let ((image (cdr (assq :poster cont))) - (url (cdr (assq :src cont))) - (start (point))) - (shr-tag-img nil image) +(defun shr-tag-audio (dom) + (let ((url (dom-attr dom 'src)) + (start (point))) + (unless url + (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 - (cdr (assq :src cont)))) - (when (and (> (current-column) 0) - (not (eq shr-state 'image))) + (and dom + (> (length (dom-attr dom 'src)) 0))) + (when (> (current-column) 0) (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) @@ -1135,10 +1380,9 @@ ones, in case fg and bg are nil." (and shr-blocked-images (string-match shr-blocked-images url))) (setq shr-start (point)) - (let ((shr-state 'space)) - (if (> (string-width alt) 8) - (shr-insert (truncate-string-to-width alt 8)) - (shr-insert alt)))) + (if (> (string-width alt) 8) + (shr-insert (truncate-string-to-width alt 8)) + (shr-insert alt))) ((and (not shr-ignore-cache) (url-is-cached (shr-encode-url url))) (funcall shr-put-image-function (shr-get-image-data url) alt)) @@ -1159,108 +1403,131 @@ ones, in case fg and bg are nil." (put-text-property start (point) 'image-url url) (put-text-property start (point) 'image-displayer (shr-image-displayer shr-content-function)) - (put-text-property start (point) 'help-echo alt)) - (setq shr-state 'image))))) + (put-text-property start (point) 'help-echo + (shr-fill-text + (or (dom-attr dom 'title) alt)))))))) -(defun shr-tag-pre (cont) - (let ((shr-folding-mode 'none)) +(defun shr-tag-pre (dom) + (let ((shr-folding-mode 'none) + (shr-current-font 'default)) (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-ensure-paragraph)) + (let ((start (point)) + (shr-indentation (+ shr-indentation + (* 4 shr-table-separator-pixel-width)))) + (shr-generic dom) + (shr-ensure-paragraph) + (shr-mark-fill start))) -(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))) + (let ((shr-indentation (+ shr-indentation + (* 4 shr-table-separator-pixel-width)))) + (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 - (if (numberp shr-list-mode) - (prog1 - (format "%d " shr-list-mode) - (setq shr-list-mode (1+ shr-list-mode))) - shr-bullet)) - (shr-indentation (+ shr-indentation (length bullet)))) - (insert bullet) - (shr-generic cont))) - -(defun shr-tag-br (cont) + (let ((start (point))) + (let* ((bullet + (if (numberp shr-list-mode) + (prog1 + (format "%d " shr-list-mode) + (setq shr-list-mode (1+ shr-list-mode))) + (car shr-internal-bullet))) + (width (if (numberp shr-list-mode) + (shr-string-pixel-width bullet) + (cdr shr-internal-bullet)))) + (insert bullet) + (shr-mark-fill start) + (let ((shr-indentation (+ shr-indentation width))) + (put-text-property start (1+ start) + 'shr-continuation-indentation shr-indentation) + (put-text-property start (1+ start) 'shr-prefix-length (length bullet)) + (shr-generic dom))))) + +(defun shr-mark-fill (start) + ;; We may not have inserted any text to fill. + (unless (= start (point)) + (put-text-property start (1+ start) + 'shr-indentation shr-indentation))) + +(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. (or (not (bolp)) (and (> (- (point) 2) (point-min)) (not (= (char-after (- (point) 2)) ?\n))))) - (insert "\n") - (shr-indent)) - (shr-generic cont)) + (insert "\n")) + (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 (if shr-use-fonts + '(variable-pitch (:height 1.3 :weight bold)) + 'bold))) -(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 (if (not shr-use-fonts) + shr-internal-width + (1+ (/ shr-internal-width + shr-table-separator-pixel-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)))))) @@ -1275,40 +1542,43 @@ ones, in case fg and bg are nil." ;; 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)) - ;; Compute how many characters wide each TD should be. + (columns (shr-column-specs dom)) + ;; Compute how many pixels 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)) - ;; 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))) + (elems (or (dom-attr dom 'shr-suggested-widths) + (shr-make-table dom suggested-widths nil + 'shr-suggested-widths))) + (sketch (loop for line in elems + collect (mapcar #'car line))) + (natural (loop for line in elems + collect (mapcar #'cdr line))) (sketch-widths (shr-table-widths sketch natural suggested-widths))) ;; This probably won't work very well. (when (> (+ (loop for width across sketch-widths summing (1+ width)) - shr-indentation 1) + shr-indentation shr-table-separator-pixel-width) (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)) @@ -1317,51 +1587,78 @@ ones, in case fg and bg are nil." (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 - ;; hader + 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)))))) + (if (dom-attr dom 'shr-fixed-table) + (shr-tag-table-1 dom) + ;; Only fix up the table once. + (let ((table + (nconc + (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))))) + (dom-set-attribute table 'shr-fixed-table t) + (setcdr dom (cdr table)) + (shr-tag-table-1 dom)))) (when bgcolor (shr-colorize-region start (point) (cdr (assq 'color shr-stylesheet)) bgcolor)) @@ -1369,54 +1666,113 @@ ones, in case fg and bg are nil." ;; 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))) + (save-excursion + (shr-expand-alignments start (point))) + (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)) "collapse")) (shr-table-separator-length (if collapse 0 1)) - (shr-table-vertical-line (if collapse "" shr-table-vertical-line))) + (shr-table-vertical-line (if collapse "" shr-table-vertical-line)) + (start (point))) + (setq shr-table-id (1+ shr-table-id)) (unless collapse (shr-insert-table-ruler widths)) (dolist (row table) (let ((start (point)) + (align 0) + (column-number 0) (height (let ((max 0)) (dolist (column row) - (setq max (max max (cadr column)))) + (setq max (max max (nth 2 column)))) max))) - (dotimes (i height) + (dotimes (i (max height 1)) (shr-indent) (insert shr-table-vertical-line "\n")) (dolist (column row) - (goto-char start) - (let ((lines (nth 2 column))) - (dolist (line lines) - (end-of-line) - (insert line shr-table-vertical-line) - (forward-line 1)) - ;; Add blank lines at padding at the bottom of the TD, - ;; possibly. - (dotimes (i (- height (length lines))) - (end-of-line) - (let ((start (point))) - (insert (make-string (string-width (car lines)) ? ) - shr-table-vertical-line) - (when (nth 4 column) - (shr-add-font start (1- (point)) - (list :background (nth 4 column))))) - (forward-line 1))))) + (when (> (nth 2 column) -1) + (goto-char start) + ;; Sum up all the widths from the column. (There may be + ;; more than one if this is a "colspan" column.) + (dotimes (i (nth 4 column)) + ;; The colspan directive may be wrong and there may not be + ;; that number of columns. + (when (<= column-number (1- (length widths))) + (setq align (+ align + (aref widths column-number) + (* 2 shr-table-separator-pixel-width)))) + (setq column-number (1+ column-number))) + (let ((lines (nth 3 column)) + (pixel-align (if (not shr-use-fonts) + (* align (frame-char-width)) + align))) + (dolist (line lines) + (end-of-line) + (let ((start (point))) + (insert + line + (propertize " " + 'display `(space :align-to (,pixel-align)) + 'face (and (> (length line) 0) + (shr-face-background + (get-text-property + (1- (length line)) 'face line))) + 'shr-table-indent shr-table-id) + shr-table-vertical-line) + (shr-colorize-region + start (1- (point)) (nth 5 column) (nth 6 column))) + (forward-line 1)) + ;; Add blank lines at padding at the bottom of the TD, + ;; possibly. + (dotimes (i (- height (length lines))) + (end-of-line) + (let ((start (point))) + (insert (propertize " " + 'display `(space :align-to (,pixel-align)) + 'shr-table-indent shr-table-id) + shr-table-vertical-line) + (shr-colorize-region + start (1- (point)) (nth 5 column) (nth 6 column))) + (forward-line 1)))))) (unless collapse - (shr-insert-table-ruler widths))))) + (shr-insert-table-ruler widths))) + (unless (= start (point)) + (put-text-property start (1+ start) 'shr-table-id shr-table-id)))) + +(defun shr-face-background (face) + (and (consp face) + (let ((background nil)) + (dolist (elem face) + (when (and (consp elem) + (eq (car elem) :background)) + (setq background (cadr elem)))) + (and background + (list :background background))))) + +(defun shr-expand-alignments (start end) + (while (< (setq start (next-single-property-change + start 'shr-table-id nil end)) + end) + (goto-char start) + (let* ((shr-use-fonts t) + (id (get-text-property (point) 'shr-table-id)) + (base (shr-pixel-column)) + elem) + (when id + (save-excursion + (while (setq elem (text-property-any + (point) end 'shr-table-indent id)) + (goto-char elem) + (let ((align (get-text-property (point) 'display))) + (put-text-property (point) (1+ (point)) 'display + `(space :align-to (,(+ (car (nth 2 align)) + base))))) + (forward-char 1))))) + (setq start (1+ start)))) (defun shr-insert-table-ruler (widths) (when shr-table-horizontal-line @@ -1424,9 +1780,17 @@ ones, in case fg and bg are nil." (> shr-indentation 0)) (shr-indent)) (insert shr-table-corner) - (dotimes (i (length widths)) - (insert (make-string (aref widths i) shr-table-horizontal-line) - shr-table-corner)) + (let ((total-width 0)) + (dotimes (i (length widths)) + (setq total-width (+ total-width (aref widths i) + (* shr-table-separator-pixel-width 2))) + (insert (make-string (1+ (/ (aref widths i) + shr-table-separator-pixel-width)) + shr-table-horizontal-line) + (propertize " " + 'display `(space :align-to (,total-width)) + 'shr-table-indent shr-table-id) + shr-table-corner))) (insert "\n"))) (defun shr-table-widths (table natural-table suggested-widths) @@ -1444,7 +1808,8 @@ ones, in case fg and bg are nil." (aset natural-widths i (max (aref natural-widths i) column)) (setq i (1+ i))))) (let ((extra (- (apply '+ (append suggested-widths nil)) - (apply '+ (append widths nil)))) + (apply '+ (append widths nil)) + (* shr-table-separator-pixel-width (1+ (length widths))))) (expanded-columns 0)) ;; We have extra, unused space, so divide this space amongst the ;; columns. @@ -1462,22 +1827,25 @@ ones, in case fg and bg are nil." (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 storage-attribute) + (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) + (when storage-attribute + (dom-set-attribute dom storage-attribute data)) 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)) + (colspan-remaining 0) + colspan-width colspan-count 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-non-text-children row)) (i 0) (width-column 0) column) @@ -1491,61 +1859,137 @@ ones, in case fg and bg are nil." (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)) (setq width (if column (aref widths width-column) - 10)) - (when (and fill - (setq colspan (cdr (assq :colspan (cdr column))))) + (* 10 shr-table-separator-pixel-width))) + (when (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 ;; remaining columns. (- (length widths) i))) (dotimes (j (1- colspan)) - (if (> (+ i 1 j) (1- (length widths))) - (setq width (aref widths (1- (length widths)))) - (setq width (+ width - shr-table-separator-length - (aref widths (+ i 1 j)))))) - (setq width-column (+ width-column (1- colspan)))) - (when (or column - (not fill)) - (push (shr-render-td (cdr column) width fill) - tds)) + (setq width + (if (> (+ i 1 j) (1- (length widths))) + ;; If we have a colspan spec that's longer + ;; than the table is wide, just use the last + ;; width as the width. + (aref widths (1- (length widths))) + ;; Sum up the widths of the columns we're + ;; spanning. + (+ width + shr-table-separator-length + (aref widths (+ i 1 j)))))) + (setq width-column (+ width-column (1- colspan)) + colspan-count colspan + colspan-remaining colspan)) + (when column + (let ((data (shr-render-td column width fill))) + (if (and (not fill) + (> colspan-remaining 0)) + (progn + (setq colspan-width (car data)) + (let ((this-width (/ colspan-width colspan-count))) + (push (cons this-width (cadr data)) tds) + (setq colspan-remaining (1- colspan-remaining)))) + (if (not fill) + (push (cons (car data) (cadr data)) tds) + (push data tds))))) + (when (and colspan + (> colspan 1)) + (dotimes (c (1- colspan)) + (setq i (1+ i)) + (push + (if fill + (list 0 0 -1 nil 1 nil nil) + '(0 . 0)) + 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-pixel-buffer-width () + (if (not shr-use-fonts) + (save-excursion + (goto-char (point-min)) + (let ((max 0)) + (while (not (eobp)) + (end-of-line) + (setq max (max max (current-column))) + (forward-line 1)) + max)) + (if (get-buffer-window) + (car (window-text-pixel-size nil (point-min) (point-max))) + (save-window-excursion + (set-window-buffer nil (current-buffer)) + (car (window-text-pixel-size nil (point-min) (point-max))))))) + +(defun shr-render-td (dom width fill) + (let ((cache (intern (format "shr-td-cache-%s-%s" width fill)))) + (or (dom-attr dom cache) + (and fill + (let (result) + (dolist (attr (dom-attributes dom)) + (let ((name (symbol-name (car attr)))) + (when (string-match "shr-td-cache-\\([0-9]+\\)-nil" name) + (let ((cache-width (string-to-number + (match-string 1 name)))) + (when (and (>= cache-width width) + (<= (car (cdr attr)) width)) + (setq result (cdr attr))))))) + result)) + (let ((result (shr-render-td-1 dom width fill))) + (dom-set-attribute dom cache result) + result)))) + +(defun shr-render-td-1 (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) + (max-width 0) + natural-width) (when style (setq style (and (string-match "color" style) (shr-parse-style style)))) (when bgcolor - (setq style (nconc (list (cons 'background-color bgcolor)) style))) + (setq style (nconc (list (cons 'background-color bgcolor)) + style))) (when fgcolor (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)) + (save-window-excursion + (set-window-buffer nil (current-buffer)) + (unless fill + (setq natural-width + (or (dom-attr dom 'shr-td-cache-natural) + (let ((natural (max (shr-pixel-buffer-width) + (shr-dom-max-natural-width dom 0)))) + (dom-set-attribute dom 'shr-td-cache-natural natural) + natural)))) + (if (and natural-width + (<= natural-width width)) + (setq max-width natural-width) + (let ((shr-internal-width width)) + (shr-fill-lines (point-min) (point-max)) + (setq max-width (shr-pixel-buffer-width))))) + (goto-char (point-max)) ;; Delete padding at the bottom of the TDs. (delete-region (point) @@ -1554,48 +1998,31 @@ ones, in case fg and bg are nil." (end-of-line) (point))) (goto-char (point-min)) - (let ((max 0)) - (while (not (eobp)) - (end-of-line) - (setq max (max max (current-column))) - (forward-line 1)) - (when fill - (goto-char (point-min)) - ;; If the buffer is totally empty, then put a single blank - ;; line here. - (if (zerop (buffer-size)) - (insert (make-string width ? )) - ;; Otherwise, fill the buffer. - (let ((align (cdr (assq :align cont))) - length) - (while (not (eobp)) - (end-of-line) - (setq length (- width (current-column))) - (when (> length 0) - (cond - ((equal align "right") - (beginning-of-line) - (insert (make-string length ? ))) - ((equal align "center") - (insert (make-string (/ length 2) ? )) - (beginning-of-line) - (insert (make-string (- length (/ length 2)) ? ))) - (t - (insert (make-string length ? ))))) - (forward-line 1)))) - (when style - (setq actual-colors - (shr-colorize-region - (point-min) (point-max) - (cdr (assq 'color shr-stylesheet)) - (cdr (assq 'background-color shr-stylesheet)))))) - (if fill - (list max - (count-lines (point-min) (point-max)) - (split-string (buffer-string) "\n") - nil - (car actual-colors)) - max))))) + (list max-width + natural-width + (count-lines (point-min) (point-max)) + (split-string (buffer-string) "\n") + (if (dom-attr dom 'colspan) + (string-to-number (dom-attr dom 'colspan)) + 1) + (cdr (assq 'color shr-stylesheet)) + (cdr (assq 'background-color shr-stylesheet)))))) + +(defun shr-dom-max-natural-width (dom max) + (if (eq (dom-tag dom) 'table) + (max max (or + (loop for line in (dom-attr dom 'shr-suggested-widths) + maximize (+ + shr-table-separator-length + (loop for elem in line + summing + (+ (cdr elem) + (* 2 shr-table-separator-length))))) + 0)) + (dolist (child (dom-children dom)) + (unless (stringp child) + (setq max (max (shr-dom-max-natural-width child max))))) + max)) (defun shr-buffer-width () (goto-char (point-min)) @@ -1615,19 +2042,21 @@ ones, in case fg and bg are nil." (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)) + shr-table-separator-pixel-width)))) 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-non-text-children row)) + (when (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 @@ -1636,25 +2065,23 @@ ones, in case fg and bg are nil." (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) -;; Local Variables: -;; coding: utf-8 -;; End: - ;;; shr.el ends here diff --git a/lisp/net/snmp-mode.el b/lisp/net/snmp-mode.el index cdefc22cd87..e5740ac560e 100644 --- a/lisp/net/snmp-mode.el +++ b/lisp/net/snmp-mode.el @@ -1,6 +1,6 @@ ;;; snmp-mode.el --- SNMP & SNMPv2 MIB major mode -;; Copyright (C) 1995, 1998, 2001-2013 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1998, 2001-2015 Free Software Foundation, Inc. ;; Author: Paul D. Smith <psmith@BayNetworks.com> ;; Keywords: data diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el index 1d4a9b573da..264a39c1899 100644 --- a/lisp/net/soap-client.el +++ b/lisp/net/soap-client.el @@ -1,12 +1,14 @@ -;;;; soap-client.el -- Access SOAP web services from Emacs +;;;; soap-client.el -- Access SOAP web services -*- lexical-binding: t -*- -;; Copyright (C) 2009-2013 Free Software Foundation, Inc. +;; Copyright (C) 2009-2015 Free Software Foundation, Inc. ;; Author: Alexandru Harsanyi <AlexHarsanyi@gmail.com> +;; Author: Thomas Fitzsimmons <fitzsim@fitzsim.org> ;; Created: December, 2009 +;; Version: 3.0.1 ;; Keywords: soap, web-services, comm, hypermedia ;; Package: soap-client -;; Homepage: http://code.google.com/p/emacs-soap-client +;; Homepage: https://github.com/alex-hhh/emacs-soap-client ;; This file is part of GNU Emacs. @@ -43,15 +45,20 @@ (eval-when-compile (require 'cl)) (require 'xml) +(require 'xsd-regexp) +(require 'rng-xsd) +(require 'rng-dt) (require 'warnings) (require 'url) (require 'url-http) (require 'url-util) +(require 'url-vars) (require 'mm-decode) (defsubst soap-warning (message &rest args) "Display a warning MESSAGE with ARGS, using the 'soap-client warning type." - (display-warning 'soap-client (apply 'format message args) :warning)) + (display-warning 'soap-client (apply #'format-message message args) + :warning)) (defgroup soap-client nil "Access SOAP web services from Emacs." @@ -73,13 +80,17 @@ ("wsdlsoap" . "http://schemas.xmlsoap.org/wsdl/soap/") ("xsd" . "http://www.w3.org/2001/XMLSchema") ("xsi" . "http://www.w3.org/2001/XMLSchema-instance") + ("wsa" . "http://www.w3.org/2005/08/addressing") + ("wsaw" . "http://www.w3.org/2006/05/addressing/wsdl") ("soap" . "http://schemas.xmlsoap.org/soap/envelope/") ("soap12" . "http://schemas.xmlsoap.org/wsdl/soap12/") ("http" . "http://schemas.xmlsoap.org/wsdl/http/") - ("mime" . "http://schemas.xmlsoap.org/wsdl/mime/")) + ("mime" . "http://schemas.xmlsoap.org/wsdl/mime/") + ("xml" . "http://www.w3.org/XML/1998/namespace")) "A list of well known xml namespaces and their aliases.") -(defvar soap-local-xmlns nil +(defvar soap-local-xmlns + '(("xml" . "http://www.w3.org/XML/1998/namespace")) "A list of local namespace aliases. This is a dynamically bound variable, controlled by `soap-with-local-xmlns'.") @@ -97,6 +108,10 @@ are fully qualified for a different namespace. This is a dynamically bound variable, controlled by `soap-with-local-xmlns'") +(defvar soap-current-wsdl nil + "The current WSDL document used when decoding the SOAP response. +This is a dynamically bound variable.") + (defun soap-wk2l (well-known-name) "Return local variant of WELL-KNOWN-NAME. This is done by looking up the namespace in the @@ -105,24 +120,24 @@ the local name based on the current local translation table `soap-local-xmlns'. See also `soap-with-local-xmlns'." (let ((wk-name-1 (if (symbolp well-known-name) (symbol-name well-known-name) - well-known-name))) + well-known-name))) (cond - ((string-match "^\\(.*\\):\\(.*\\)$" wk-name-1) - (let ((ns (match-string 1 wk-name-1)) - (name (match-string 2 wk-name-1))) - (let ((namespace (cdr (assoc ns soap-well-known-xmlns)))) - (cond ((equal namespace soap-default-xmlns) - ;; Name is unqualified in the default namespace - (if (symbolp well-known-name) - (intern name) - name)) - (t - (let* ((local-ns (car (rassoc namespace soap-local-xmlns))) - (local-name (concat local-ns ":" name))) - (if (symbolp well-known-name) - (intern local-name) - local-name))))))) - (t well-known-name)))) + ((string-match "^\\(.*\\):\\(.*\\)$" wk-name-1) + (let ((ns (match-string 1 wk-name-1)) + (name (match-string 2 wk-name-1))) + (let ((namespace (cdr (assoc ns soap-well-known-xmlns)))) + (cond ((equal namespace soap-default-xmlns) + ;; Name is unqualified in the default namespace + (if (symbolp well-known-name) + (intern name) + name)) + (t + (let* ((local-ns (car (rassoc namespace soap-local-xmlns))) + (local-name (concat local-ns ":" name))) + (if (symbolp well-known-name) + (intern local-name) + local-name))))))) + (t well-known-name)))) (defun soap-l2wk (local-name) "Convert LOCAL-NAME into a well known name. @@ -133,40 +148,37 @@ used in the name. nil is returned if there is no well-known namespace for the namespace of LOCAL-NAME." (let ((l-name-1 (if (symbolp local-name) - (symbol-name local-name) - local-name)) + (symbol-name local-name) + local-name)) namespace name) (cond - ((string-match "^\\(.*\\):\\(.*\\)$" l-name-1) - (setq name (match-string 2 l-name-1)) - (let ((ns (match-string 1 l-name-1))) - (setq namespace (cdr (assoc ns soap-local-xmlns))) - (unless namespace - (error "Soap-l2wk(%s): no namespace for alias %s" local-name ns)))) - (t - (setq name l-name-1) - (setq namespace soap-default-xmlns))) + ((string-match "^\\(.*\\):\\(.*\\)$" l-name-1) + (setq name (match-string 2 l-name-1)) + (let ((ns (match-string 1 l-name-1))) + (setq namespace (cdr (assoc ns soap-local-xmlns))) + (unless namespace + (error "Soap-l2wk(%s): no namespace for alias %s" local-name ns)))) + (t + (setq name l-name-1) + (setq namespace soap-default-xmlns))) (if namespace (let ((well-known-ns (car (rassoc namespace soap-well-known-xmlns)))) (if well-known-ns (let ((well-known-name (concat well-known-ns ":" name))) - (if (symbol-name local-name) + (if (symbolp local-name) (intern well-known-name) - well-known-name)) - (progn - ;; (soap-warning "soap-l2wk(%s): namespace %s has no well-known tag" - ;; local-name namespace) - nil))) - ;; if no namespace is defined, just return the unqualified name - name))) + well-known-name)) + nil)) + ;; if no namespace is defined, just return the unqualified name + name))) (defun soap-l2fq (local-name &optional use-tns) "Convert LOCAL-NAME into a fully qualified name. A fully qualified name is a cons of the namespace name and the name of the element itself. For example \"xsd:string\" is -converted to \(\"http://www.w3.org/2001/XMLSchema\" . \"string\"\). +converted to (\"http://www.w3.org/2001/XMLSchema\" . \"string\"). The USE-TNS argument specifies what to do when LOCAL-NAME has no namespace tag. If USE-TNS is non-nil, the `soap-target-xmlns' @@ -177,19 +189,27 @@ This is needed because different parts of a WSDL document can use different namespace aliases for the same element." (let ((local-name-1 (if (symbolp local-name) (symbol-name local-name) - local-name))) + local-name))) (cond ((string-match "^\\(.*\\):\\(.*\\)$" local-name-1) (let ((ns (match-string 1 local-name-1)) (name (match-string 2 local-name-1))) (let ((namespace (cdr (assoc ns soap-local-xmlns)))) (if namespace (cons namespace name) - (error "Soap-l2fq(%s): unknown alias %s" local-name ns))))) + (error "Soap-l2fq(%s): unknown alias %s" local-name ns))))) (t (cons (if use-tns soap-target-xmlns - soap-default-xmlns) - local-name))))) + soap-default-xmlns) + local-name-1))))) + +(defun soap-name-p (name) + "Return true if NAME is a valid name for XMLSchema types. +A valid name is either a string or a cons of (NAMESPACE . NAME)." + (or (stringp name) + (and (consp name) + (stringp (car name)) + (stringp (cdr name))))) (defun soap-extract-xmlns (node &optional xmlns-table) "Return a namespace alias table for NODE by extending XMLNS-TABLE." @@ -210,16 +230,10 @@ different namespace aliases for the same element." ;; the target namespace. (unless (equal target-ns (cdr tns)) (soap-warning - "soap-extract-xmlns(%s): tns alias and targetNamespace mismatch" - (xml-node-name node)))) + "soap-extract-xmlns(%s): tns alias and targetNamespace mismatch" + (xml-node-name node)))) ((and tns (not target-ns)) - (setq target-ns (cdr tns))) - ((and (not tns) target-ns) - ;; a tns alias was not defined in this node. See if the node has - ;; a "targetNamespace" attribute and add an alias to this. Note - ;; that we might override an existing tns alias in XMLNS-TABLE, - ;; but that is intended. - (push (cons "tns" target-ns) xmlns)))) + (setq target-ns (cdr tns))))) (list default-ns target-ns (append xmlns xmlns-table)))) @@ -249,13 +263,21 @@ namespace tag." (when (and (consp c) (soap-with-local-xmlns c ;; We use `ignore-errors' here because we want to silently - ;; skip nodes for which we cannot convert them to a - ;; well-known name. + ;; skip nodes when we cannot convert them to a well-known + ;; name. (eq (ignore-errors (soap-l2wk (xml-node-name c))) - child-name))) + child-name))) (push c result))) (nreverse result))) +(defun soap-xml-node-find-matching-child (node set) + "Return the first child of NODE whose name is a member of SET." + (catch 'found + (dolist (child (xml-node-children node)) + (when (and (consp child) + (memq (soap-l2wk (xml-node-name child)) set)) + (throw 'found child))))) + (defun soap-xml-get-attribute-or-nil1 (node attribute) "Return the NODE's ATTRIBUTE, or nil if it does not exist. This is the same as `xml-get-attribute-or-nil', but ATTRIBUTE can @@ -286,8 +308,13 @@ be tagged with a namespace tag." "Return a fully qualified name for ELEMENT. A fq name is the concatenation of the namespace tag and the element name." - (concat (soap-element-namespace-tag element) - ":" (soap-element-name element))) + (cond ((soap-element-namespace-tag element) + (concat (soap-element-namespace-tag element) + ":" (soap-element-name element))) + ((soap-element-name element) + (soap-element-name element)) + (t + "*unnamed*"))) ;; a namespace link stores an alias for an object in once namespace to a ;; "target" object possibly in a different namespace @@ -310,11 +337,8 @@ discriminant predicate to `soap-namespace-get'" (let ((name (soap-element-name element))) (push element (gethash name (soap-namespace-elements ns))))) -(defun soap-namespace-put-link (name target ns &optional replace) +(defun soap-namespace-put-link (name target ns) "Store a link from NAME to TARGET in NS. -An error will be signaled if an element by the same name is -already present in NS, unless REPLACE is non nil. - TARGET can be either a SOAP-ELEMENT or a string denoting an element name into another namespace. @@ -356,34 +380,1563 @@ binding) but the same name." ((= (length elements) 1) (car elements)) ((> (length elements) 1) (error - "Soap-namespace-get(%s): multiple elements, discriminant needed" - name)) + "Soap-namespace-get(%s): multiple elements, discriminant needed" + name)) (t nil)))) -;;;; WSDL documents -;;;;; WSDL document elements +;;;; XML Schema -(defstruct (soap-basic-type (:include soap-element)) - kind ; a symbol of: string, dateTime, long, int - ) +;; SOAP WSDL documents use XML Schema to define the types that are part of the +;; message exchange. We include here an XML schema model with a parser and +;; serializer/deserialiser. -(defstruct (soap-simple-type (:include soap-basic-type)) - enumeration) +(defstruct (soap-xs-type (:include soap-element)) + id + attributes + attribute-groups) -(defstruct soap-sequence-element - name type nillable? multiple?) +;;;;; soap-xs-basic-type -(defstruct (soap-sequence-type (:include soap-element)) - parent ; OPTIONAL WSDL-TYPE name - elements ; LIST of SOAP-SEQUENCE-ELEMENT +(defstruct (soap-xs-basic-type (:include soap-xs-type)) + ;; Basic types are "built in" and we know how to handle them directly. + ;; Other type definitions reference basic types, so we need to create them + ;; in a namespace (see `soap-make-xs-basic-types') + + ;; a symbol of: string, dateTime, long, int, etc + kind ) -(defstruct (soap-array-type (:include soap-element)) - element-type ; WSDL-TYPE of the array elements +(defun soap-make-xs-basic-types (namespace-name &optional namespace-tag) + "Construct NAMESPACE-NAME containing the XMLSchema basic types. +An optional NAMESPACE-TAG can also be specified." + (let ((ns (make-soap-namespace :name namespace-name))) + (dolist (type '("string" "language" "ID" "IDREF" + "dateTime" "time" "date" "boolean" + "gYearMonth" "gYear" "gMonthDay" "gDay" "gMonth" + "long" "short" "int" "integer" "nonNegativeInteger" + "unsignedLong" "unsignedShort" "unsignedInt" + "decimal" "duration" + "byte" "unsignedByte" + "float" "double" + "base64Binary" "anyType" "anyURI" "QName" "Array" "byte[]")) + (soap-namespace-put + (make-soap-xs-basic-type :name type + :namespace-tag namespace-tag + :kind (intern type)) + ns)) + ns)) + +(defun soap-encode-xs-basic-type-attributes (value type) + "Encode the XML attributes for VALUE according to TYPE. +The xsi:type and an optional xsi:nil attributes are added. The +attributes are inserted in the current buffer at the current +position. + +This is a specialization of `soap-encode-attributes' for +`soap-xs-basic-type' objects." + (let ((xsi-type (soap-element-fq-name type)) + (basic-type (soap-xs-basic-type-kind type))) + ;; try to classify the type based on the value type and use that type when + ;; encoding + (when (eq basic-type 'anyType) + (cond ((stringp value) + (setq xsi-type "xsd:string" basic-type 'string)) + ((integerp value) + (setq xsi-type "xsd:int" basic-type 'int)) + ((memq value '(t nil)) + (setq xsi-type "xsd:boolean" basic-type 'boolean)) + (t + (error "Cannot classify anyType value")))) + + (insert " xsi:type=\"" xsi-type "\"") + ;; We have some ambiguity here, as a nil value represents "false" when the + ;; type is boolean, we will never have a "nil" boolean type... + (unless (or value (eq basic-type 'boolean)) + (insert " xsi:nil=\"true\"")))) + +(defun soap-encode-xs-basic-type (value type) + "Encode the VALUE according to TYPE. +The data is inserted in the current buffer at the current +position. + +This is a specialization of `soap-encode-value' for +`soap-xs-basic-type' objects." + (let ((kind (soap-xs-basic-type-kind type))) + + (when (eq kind 'anyType) + (cond ((stringp value) + (setq kind 'string)) + ((integerp value) + (setq kind 'int)) + ((memq value '(t nil)) + (setq kind 'boolean)) + (t + (error "Cannot classify anyType value")))) + + ;; NOTE: a nil value is not encoded, as an xsi:nil="true" attribute was + ;; encoded for it. However, we have some ambiguity here, as a nil value + ;; also represents "false" when the type is boolean... + + (when (or value (eq kind 'boolean)) + (let ((value-string + (case kind + ((string anyURI QName ID IDREF language) + (unless (stringp value) + (error "Not a string value: %s" value)) + (url-insert-entities-in-string value)) + ((dateTime time date gYearMonth gYear gMonthDay gDay gMonth) + (cond ((consp value) + ;; Value is a (current-time) style value, + ;; convert to the ISO 8601-inspired XSD + ;; string format in UTC. + (format-time-string + (concat + (ecase kind + (dateTime "%Y-%m-%dT%H:%M:%S") + (time "%H:%M:%S") + (date "%Y-%m-%d") + (gYearMonth "%Y-%m") + (gYear "%Y") + (gMonthDay "--%m-%d") + (gDay "---%d") + (gMonth "--%m")) + ;; Internal time is always in UTC. + "Z") + value t)) + ((stringp value) + ;; Value is a string in the ISO 8601-inspired XSD + ;; format. Validate it. + (soap-decode-date-time value kind) + (url-insert-entities-in-string value)) + (t + (error "Invalid date-time format")))) + (boolean + (unless (memq value '(t nil)) + (error "Not a boolean value")) + (if value "true" "false")) + + ((long short int integer byte unsignedInt unsignedLong + unsignedShort nonNegativeInteger decimal duration) + (unless (integerp value) + (error "Not an integer value")) + (when (and (memq kind '(unsignedInt unsignedLong + unsignedShort + nonNegativeInteger)) + (< value 0)) + (error "Not a positive integer")) + (number-to-string value)) + + ((float double) + (unless (numberp value) + (error "Not a number")) + (number-to-string value)) + + (base64Binary + (unless (stringp value) + (error "Not a string value for base64Binary")) + (base64-encode-string value)) + + (otherwise + (error "Don't know how to encode %s for type %s" + value (soap-element-fq-name type)))))) + (soap-validate-xs-basic-type value-string type) + (insert value-string))))) + +;; Inspired by rng-xsd-convert-date-time. +(defun soap-decode-date-time (date-time-string datatype) + "Decode DATE-TIME-STRING as DATATYPE. +DATE-TIME-STRING should be in ISO 8601 basic or extended format. +DATATYPE is one of dateTime, time, date, gYearMonth, gYear, +gMonthDay, gDay or gMonth. + +Return a list in a format (SEC MINUTE HOUR DAY MONTH YEAR +SEC-FRACTION DATATYPE ZONE). This format is meant to be similar +to that returned by `decode-time' (and compatible with +`encode-time'). The differences are the DOW (day-of-week) field +is replaced with SEC-FRACTION, a float representing the +fractional seconds, and the DST (daylight savings time) field is +replaced with DATATYPE, a symbol representing the XSD primitive +datatype. This symbol can be used to determine which fields +apply and which don't when it's not already clear from context. +For example a datatype of 'time means the year, month and day +fields should be ignored. + +This function will throw an error if DATE-TIME-STRING represents +a leap second, since the XML Schema 1.1 standard explicitly +disallows them." + (let* ((datetime-regexp (cadr (get datatype 'rng-xsd-convert))) + (year-sign (progn + (string-match datetime-regexp date-time-string) + (match-string 1 date-time-string))) + (year (match-string 2 date-time-string)) + (month (match-string 3 date-time-string)) + (day (match-string 4 date-time-string)) + (hour (match-string 5 date-time-string)) + (minute (match-string 6 date-time-string)) + (second (match-string 7 date-time-string)) + (second-fraction (match-string 8 date-time-string)) + (has-time-zone (match-string 9 date-time-string)) + (time-zone-sign (match-string 10 date-time-string)) + (time-zone-hour (match-string 11 date-time-string)) + (time-zone-minute (match-string 12 date-time-string))) + (setq year-sign (if year-sign -1 1)) + (setq year + (if year + (* year-sign + (string-to-number year)) + ;; By defaulting to the epoch date, a time value can be treated as + ;; a relative number of seconds. + 1970)) + (setq month + (if month (string-to-number month) 1)) + (setq day + (if day (string-to-number day) 1)) + (setq hour + (if hour (string-to-number hour) 0)) + (setq minute + (if minute (string-to-number minute) 0)) + (setq second + (if second (string-to-number second) 0)) + (setq second-fraction + (if second-fraction + (float (string-to-number second-fraction)) + 0.0)) + (setq has-time-zone (and has-time-zone t)) + (setq time-zone-sign + (if (equal time-zone-sign "-") -1 1)) + (setq time-zone-hour + (if time-zone-hour (string-to-number time-zone-hour) 0)) + (setq time-zone-minute + (if time-zone-minute (string-to-number time-zone-minute) 0)) + (unless (and + ;; XSD does not allow year 0. + (> year 0) + (>= month 1) (<= month 12) + (>= day 1) (<= day (rng-xsd-days-in-month year month)) + (>= hour 0) (<= hour 23) + (>= minute 0) (<= minute 59) + ;; 60 represents a leap second, but leap seconds are explicitly + ;; disallowed by the XML Schema 1.1 specification. This agrees + ;; with typical Emacs installations, which don't count leap + ;; seconds in time values. + (>= second 0) (<= second 59) + (>= time-zone-hour 0) + (<= time-zone-hour 23) + (>= time-zone-minute 0) + (<= time-zone-minute 59)) + (error "Invalid or unsupported time: %s" date-time-string)) + ;; Return a value in a format similar to that returned by decode-time, and + ;; suitable for (apply 'encode-time ...). + (list second minute hour day month year second-fraction datatype + (if has-time-zone + (* (rng-xsd-time-to-seconds + time-zone-hour + time-zone-minute + 0) + time-zone-sign) + ;; UTC. + 0)))) + +(defun soap-decode-xs-basic-type (type node) + "Use TYPE, a `soap-xs-basic-type', to decode the contents of NODE. +A LISP value is returned based on the contents of NODE and the +type-info stored in TYPE. + +This is a specialization of `soap-decode-type' for +`soap-xs-basic-type' objects." + (let ((contents (xml-node-children node)) + (kind (soap-xs-basic-type-kind type)) + (attributes (xml-node-attributes node)) + (validate-type type) + (is-nil nil)) + + (dolist (attribute attributes) + (let ((attribute-type (soap-l2fq (car attribute))) + (attribute-value (cdr attribute))) + ;; xsi:type can override an element's expected type. + (when (equal attribute-type (soap-l2fq "xsi:type")) + (setq validate-type + (soap-wsdl-get attribute-value soap-current-wsdl))) + ;; xsi:nil can specify that an element is nil in which case we don't + ;; validate it. + (when (equal attribute-type (soap-l2fq "xsi:nil")) + (setq is-nil (string= (downcase attribute-value) "true"))))) + + (unless is-nil + ;; For validation purposes, when xml-node-children returns nil, treat it + ;; as the empty string. + (soap-validate-xs-basic-type (car (or contents (list ""))) validate-type)) + + (if (null contents) + nil + (ecase kind + ((string anyURI QName ID IDREF language) (car contents)) + ((dateTime time date gYearMonth gYear gMonthDay gDay gMonth) + (car contents)) + ((long short int integer + unsignedInt unsignedLong unsignedShort nonNegativeInteger + decimal byte float double duration) + (string-to-number (car contents))) + (boolean (string= (downcase (car contents)) "true")) + (base64Binary (base64-decode-string (car contents))) + (anyType (soap-decode-any-type node)) + (Array (soap-decode-array node)))))) + +;; Register methods for `soap-xs-basic-type' +(let ((tag (aref (make-soap-xs-basic-type) 0))) + (put tag 'soap-attribute-encoder #'soap-encode-xs-basic-type-attributes) + (put tag 'soap-encoder #'soap-encode-xs-basic-type) + (put tag 'soap-decoder #'soap-decode-xs-basic-type)) + +;;;;; soap-xs-element + +(defstruct (soap-xs-element (:include soap-element)) + ;; NOTE: we don't support exact number of occurrences via minOccurs, + ;; maxOccurs. Instead we support optional? and multiple? + + id + type^ ; note: use soap-xs-element-type to retrieve this member + optional? + multiple? + reference + substitution-group + ;; contains a list of elements who point to this one via their + ;; substitution-group slot + alternatives + is-group) + +(defun soap-xs-element-type (element) + "Retrieve the type of ELEMENT. +This is normally stored in the TYPE^ slot, but if this element +contains a reference, we retrive the type of the reference." + (if (soap-xs-element-reference element) + (soap-xs-element-type (soap-xs-element-reference element)) + (soap-xs-element-type^ element))) + +(defun soap-node-optional (node) + "Return t if NODE specifies an optional element." + (or (equal (xml-get-attribute-or-nil node 'nillable) "true") + (let ((e (xml-get-attribute-or-nil node 'minOccurs))) + (and e (equal e "0"))))) + +(defun soap-node-multiple (node) + "Return t if NODE permits multiple elements." + (let* ((e (xml-get-attribute-or-nil node 'maxOccurs))) + (and e (not (equal e "1"))))) + +(defun soap-xs-parse-element (node) + "Construct a `soap-xs-element' from NODE." + (let ((name (xml-get-attribute-or-nil node 'name)) + (id (xml-get-attribute-or-nil node 'id)) + (type (xml-get-attribute-or-nil node 'type)) + (optional? (soap-node-optional node)) + (multiple? (soap-node-multiple node)) + (ref (xml-get-attribute-or-nil node 'ref)) + (substitution-group (xml-get-attribute-or-nil node 'substitutionGroup)) + (node-name (soap-l2wk (xml-node-name node)))) + (assert (memq node-name '(xsd:element xsd:group)) + "expecting xsd:element or xsd:group, got %s" node-name) + + (when type + (setq type (soap-l2fq type 'tns))) + + (when ref + (setq ref (soap-l2fq ref 'tns))) + + (when substitution-group + (setq substitution-group (soap-l2fq substitution-group 'tns))) + + (unless (or ref type) + ;; no type specified and this is not a reference. Must be a type + ;; defined within this node. + (let ((simple-type (soap-xml-get-children1 node 'xsd:simpleType))) + (if simple-type + (setq type (soap-xs-parse-simple-type (car simple-type))) + ;; else + (let ((complex-type (soap-xml-get-children1 node 'xsd:complexType))) + (if complex-type + (setq type (soap-xs-parse-complex-type (car complex-type))) + ;; else + (error "Soap-xs-parse-element: missing type or ref")))))) + + (make-soap-xs-element :name name + ;; Use the full namespace name for now, we will + ;; convert it to a nstag in + ;; `soap-resolve-references-for-xs-element' + :namespace-tag soap-target-xmlns + :id id :type^ type + :optional? optional? :multiple? multiple? + :reference ref + :substitution-group substitution-group + :is-group (eq node-name 'xsd:group)))) + +(defun soap-resolve-references-for-xs-element (element wsdl) + "Replace names in ELEMENT with the referenced objects in the WSDL. +This is a specialization of `soap-resolve-references' for +`soap-xs-element' objects. + +See also `soap-wsdl-resolve-references'." + + (let ((namespace (soap-element-namespace-tag element))) + (when namespace + (let ((nstag (car (rassoc namespace (soap-wsdl-alias-table wsdl))))) + (when nstag + (setf (soap-element-namespace-tag element) nstag))))) + + (let ((type (soap-xs-element-type^ element))) + (cond ((soap-name-p type) + (setf (soap-xs-element-type^ element) + (soap-wsdl-get type wsdl 'soap-xs-type-p))) + ((soap-xs-type-p type) + ;; an inline defined type, this will not be reached from anywhere + ;; else, so we must resolve references now. + (soap-resolve-references type wsdl)))) + (let ((reference (soap-xs-element-reference element))) + (when (and (soap-name-p reference) + ;; xsd:group reference nodes will be converted to inline types + ;; by soap-resolve-references-for-xs-complex-type, so skip them + ;; here. + (not (soap-xs-element-is-group element))) + (setf (soap-xs-element-reference element) + (soap-wsdl-get reference wsdl 'soap-xs-element-p)))) + + (let ((subst (soap-xs-element-substitution-group element))) + (when (soap-name-p subst) + (let ((target (soap-wsdl-get subst wsdl))) + (if target + (push element (soap-xs-element-alternatives target)) + (soap-warning "No target found for substitution-group" subst)))))) + +(defun soap-encode-xs-element-attributes (value element) + "Encode the XML attributes for VALUE according to ELEMENT. +Currently no attributes are needed. + +This is a specialization of `soap-encode-attributes' for +`soap-xs-basic-type' objects." + ;; Use the variables to suppress checkdoc and compiler warnings. + (list value element) + nil) + +(defun soap-should-encode-value-for-xs-element (value element) + "Return t if VALUE should be encoded for ELEMENT, nil otherwise." + (cond + ;; if value is not nil, attempt to encode it + (value) + + ;; value is nil, but the element's type is a boolean, so nil in this case + ;; means "false". We need to encode it. + ((let ((type (soap-xs-element-type element))) + (and (soap-xs-basic-type-p type) + (eq (soap-xs-basic-type-kind type) 'boolean)))) + + ;; This is not an optional element. Force encoding it (although this + ;; might fail at the validation step, but this is what we intend. + + ;; value is nil, but the element's type has some attributes which supply a + ;; default value. We need to encode it. + + ((let ((type (soap-xs-element-type element))) + (catch 'found + (dolist (a (soap-xs-type-attributes type)) + (when (soap-xs-attribute-default a) + (throw 'found t)))))) + + ;; otherwise, we don't need to encode it + (t nil))) + +(defun soap-type-is-array? (type) + "Return t if TYPE defines an ARRAY." + (and (soap-xs-complex-type-p type) + (eq (soap-xs-complex-type-indicator type) 'array))) + +(defvar soap-encoded-namespaces nil + "A list of namespace tags used during encoding a message. +This list is populated by `soap-encode-value' and used by +`soap-create-envelope' to add aliases for these namespace to the +XML request. + +This variable is dynamically bound in `soap-create-envelope'.") + +(defun soap-encode-xs-element (value element) + "Encode the VALUE according to ELEMENT. +The data is inserted in the current buffer at the current +position. + +This is a specialization of `soap-encode-value' for +`soap-xs-basic-type' objects." + (let ((fq-name (soap-element-fq-name element)) + (type (soap-xs-element-type element))) + ;; Only encode the element if it has a name. NOTE: soap-element-fq-name + ;; will return *unnamed* for such elements + (if (soap-element-name element) + ;; Don't encode this element if value is nil. However, even if value + ;; is nil we still want to encode this element if it has any attributes + ;; with default values. + (when (soap-should-encode-value-for-xs-element value element) + (progn + (insert "<" fq-name) + (soap-encode-attributes value type) + ;; If value is nil and type is boolean encode the value as "false". + ;; Otherwise don't encode the value. + (if (or value (and (soap-xs-basic-type-p type) + (eq (soap-xs-basic-type-kind type) 'boolean))) + (progn (insert ">") + ;; ARRAY's need special treatment, as each element of + ;; the array is encoded with the same tag as the + ;; current element... + (if (soap-type-is-array? type) + (let ((new-element (copy-soap-xs-element element))) + (when (soap-element-namespace-tag type) + (add-to-list 'soap-encoded-namespaces + (soap-element-namespace-tag type))) + (setf (soap-xs-element-type^ new-element) + (soap-xs-complex-type-base type)) + (loop for i below (length value) + do (progn + (soap-encode-xs-element (aref value i) new-element) + ))) + (soap-encode-value value type)) + (insert "</" fq-name ">\n")) + ;; else + (insert "/>\n")))) + (when (soap-should-encode-value-for-xs-element value element) + (soap-encode-value value type))))) + +(defun soap-decode-xs-element (element node) + "Use ELEMENT, a `soap-xs-element', to decode the contents of NODE. +A LISP value is returned based on the contents of NODE and the +type-info stored in ELEMENT. + +This is a specialization of `soap-decode-type' for +`soap-xs-basic-type' objects." + (let ((type (soap-xs-element-type element))) + (soap-decode-type type node))) + +;; Register methods for `soap-xs-element' +(let ((tag (aref (make-soap-xs-element) 0))) + (put tag 'soap-resolve-references #'soap-resolve-references-for-xs-element) + (put tag 'soap-attribute-encoder #'soap-encode-xs-element-attributes) + (put tag 'soap-encoder #'soap-encode-xs-element) + (put tag 'soap-decoder #'soap-decode-xs-element)) + +;;;;; soap-xs-attribute + +(defstruct (soap-xs-attribute (:include soap-element)) + type ; a simple type or basic type + default ; the default value, if any + reference) + +(defstruct (soap-xs-attribute-group (:include soap-xs-type)) + reference) + +(defun soap-xs-parse-attribute (node) + "Construct a `soap-xs-attribute' from NODE." + (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:attribute) + "expecting xsd:attribute, got %s" (soap-l2wk (xml-node-name node))) + (let* ((name (xml-get-attribute-or-nil node 'name)) + (type (soap-l2fq (xml-get-attribute-or-nil node 'type))) + (default (xml-get-attribute-or-nil node 'fixed)) + (attribute (xml-get-attribute-or-nil node 'ref)) + (ref (when attribute (soap-l2fq attribute)))) + (unless (or type ref) + (setq type (soap-xs-parse-simple-type + (soap-xml-node-find-matching-child + node '(xsd:restriction xsd:list xsd:union))))) + (make-soap-xs-attribute + :name name :type type :default default :reference ref))) + +(defun soap-xs-parse-attribute-group (node) + "Construct a `soap-xs-attribute-group' from NODE." + (let ((node-name (soap-l2wk (xml-node-name node)))) + (assert (eq node-name 'xsd:attributeGroup) + "expecting xsd:attributeGroup, got %s" node-name) + (let ((name (xml-get-attribute-or-nil node 'name)) + (id (xml-get-attribute-or-nil node 'id)) + (ref (xml-get-attribute-or-nil node 'ref)) + attribute-group) + (when (and name ref) + (soap-warning "name and ref set for attribute group %s" node-name)) + (setq attribute-group + (make-soap-xs-attribute-group :id id + :name name + :reference (and ref (soap-l2fq ref)))) + (when (not ref) + (dolist (child (xml-node-children node)) + ;; Ignore whitespace. + (unless (stringp child) + ;; Ignore optional annotation. + ;; Ignore anyAttribute nodes. + (case (soap-l2wk (xml-node-name child)) + (xsd:attribute + (push (soap-xs-parse-attribute child) + (soap-xs-type-attributes attribute-group))) + (xsd:attributeGroup + (push (soap-xs-parse-attribute-group child) + (soap-xs-attribute-group-attribute-groups + attribute-group))))))) + attribute-group))) + +(defun soap-resolve-references-for-xs-attribute (attribute wsdl) + "Replace names in ATTRIBUTE with the referenced objects in the WSDL. +This is a specialization of `soap-resolve-references' for +`soap-xs-attribute' objects. + +See also `soap-wsdl-resolve-references'." + (let* ((type (soap-xs-attribute-type attribute)) + (reference (soap-xs-attribute-reference attribute)) + (predicate 'soap-xs-element-p) + (xml-reference + (and (soap-name-p reference) + (equal (car reference) "http://www.w3.org/XML/1998/namespace")))) + (cond (xml-reference + ;; Convert references to attributes defined by the XML + ;; schema (xml:base, xml:lang, xml:space and xml:id) to + ;; xsd:string, to avoid needing to bundle and parse + ;; xml.xsd. + (setq reference '("http://www.w3.org/2001/XMLSchema" . "string")) + (setq predicate 'soap-xs-basic-type-p)) + ((soap-name-p type) + (setf (soap-xs-attribute-type attribute) + (soap-wsdl-get type wsdl + (lambda (type) + (or (soap-xs-basic-type-p type) + (soap-xs-simple-type-p type)))))) + ((soap-xs-type-p type) + ;; an inline defined type, this will not be reached from anywhere + ;; else, so we must resolve references now. + (soap-resolve-references type wsdl))) + (when (soap-name-p reference) + (setf (soap-xs-attribute-reference attribute) + (soap-wsdl-get reference wsdl predicate))))) + +(put (aref (make-soap-xs-attribute) 0) + 'soap-resolve-references #'soap-resolve-references-for-xs-attribute) + +(defun soap-resolve-references-for-xs-attribute-group (attribute-group wsdl) + "Set slots in ATTRIBUTE-GROUP to the referenced objects in the WSDL. +This is a specialization of `soap-resolve-references' for +`soap-xs-attribute-group' objects. + +See also `soap-wsdl-resolve-references'." + (let ((reference (soap-xs-attribute-group-reference attribute-group))) + (when (soap-name-p reference) + (let ((resolved (soap-wsdl-get reference wsdl + 'soap-xs-attribute-group-p))) + (dolist (attribute (soap-xs-attribute-group-attributes resolved)) + (soap-resolve-references attribute wsdl)) + (setf (soap-xs-attribute-group-name attribute-group) + (soap-xs-attribute-group-name resolved)) + (setf (soap-xs-attribute-group-id attribute-group) + (soap-xs-attribute-group-id resolved)) + (setf (soap-xs-attribute-group-reference attribute-group) nil) + (setf (soap-xs-attribute-group-attributes attribute-group) + (soap-xs-attribute-group-attributes resolved)) + (setf (soap-xs-attribute-group-attribute-groups attribute-group) + (soap-xs-attribute-group-attribute-groups resolved)))))) + +(put (aref (make-soap-xs-attribute-group) 0) + 'soap-resolve-references #'soap-resolve-references-for-xs-attribute-group) + +;;;;; soap-xs-simple-type + +(defstruct (soap-xs-simple-type (:include soap-xs-type)) + ;; A simple type is an extension on the basic type to which some + ;; restrictions can be added. For example we can define a simple type based + ;; off "string" with the restrictions that only the strings "one", "two" and + ;; "three" are valid values (this is an enumeration). + + base ; can be a single type, or a list of types for union types + enumeration ; nil, or list of permitted values for the type + pattern ; nil, or value must match this pattern + length-range ; a cons of (min . max) length, inclusive range. + ; For exact length, use (l, l). + ; nil means no range, + ; (nil . l) means no min range, + ; (l . nil) means no max range. + integer-range ; a pair of (min, max) integer values, inclusive range, + ; same meaning as `length-range' + is-list ; t if this is an xs:list, nil otherwise ) +(defun soap-xs-parse-simple-type (node) + "Construct an `soap-xs-simple-type' object from the XML NODE." + (assert (memq (soap-l2wk (xml-node-name node)) + '(xsd:simpleType xsd:simpleContent)) + nil + "expecting xsd:simpleType or xsd:simpleContent node, got %s" + (soap-l2wk (xml-node-name node))) + + ;; NOTE: name can be nil for inline types. Such types cannot be added to a + ;; namespace. + (let ((name (xml-get-attribute-or-nil node 'name)) + (id (xml-get-attribute-or-nil node 'id))) + + (let ((type (make-soap-xs-simple-type + :name name :namespace-tag soap-target-xmlns :id id)) + (def (soap-xml-node-find-matching-child + node '(xsd:restriction xsd:extension xsd:union xsd:list)))) + (ecase (soap-l2wk (xml-node-name def)) + (xsd:restriction (soap-xs-add-restriction def type)) + (xsd:extension (soap-xs-add-extension def type)) + (xsd:union (soap-xs-add-union def type)) + (xsd:list (soap-xs-add-list def type))) + + type))) + +(defun soap-xs-add-restriction (node type) + "Add restrictions defined in XML NODE to TYPE, an `soap-xs-simple-type'." + + (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:restriction) + nil + "expecting xsd:restriction node, got %s" + (soap-l2wk (xml-node-name node))) + + (setf (soap-xs-simple-type-base type) + (soap-l2fq (xml-get-attribute node 'base))) + + (dolist (r (xml-node-children node)) + (unless (stringp r) ; skip the white space + (let ((value (xml-get-attribute r 'value))) + (case (soap-l2wk (xml-node-name r)) + (xsd:enumeration + (push value (soap-xs-simple-type-enumeration type))) + (xsd:pattern + (setf (soap-xs-simple-type-pattern type) + (concat "\\`" (xsdre-translate value) "\\'"))) + (xsd:length + (let ((value (string-to-number value))) + (setf (soap-xs-simple-type-length-range type) + (cons value value)))) + (xsd:minLength + (let ((value (string-to-number value))) + (setf (soap-xs-simple-type-length-range type) + (if (soap-xs-simple-type-length-range type) + (cons value + (cdr (soap-xs-simple-type-length-range type))) + ;; else + (cons value nil))))) + (xsd:maxLength + (let ((value (string-to-number value))) + (setf (soap-xs-simple-type-length-range type) + (if (soap-xs-simple-type-length-range type) + (cons (car (soap-xs-simple-type-length-range type)) + value) + ;; else + (cons nil value))))) + (xsd:minExclusive + (let ((value (string-to-number value))) + (setf (soap-xs-simple-type-integer-range type) + (if (soap-xs-simple-type-integer-range type) + (cons (1+ value) + (cdr (soap-xs-simple-type-integer-range type))) + ;; else + (cons (1+ value) nil))))) + (xsd:maxExclusive + (let ((value (string-to-number value))) + (setf (soap-xs-simple-type-integer-range type) + (if (soap-xs-simple-type-integer-range type) + (cons (car (soap-xs-simple-type-integer-range type)) + (1- value)) + ;; else + (cons nil (1- value)))))) + (xsd:minInclusive + (let ((value (string-to-number value))) + (setf (soap-xs-simple-type-integer-range type) + (if (soap-xs-simple-type-integer-range type) + (cons value + (cdr (soap-xs-simple-type-integer-range type))) + ;; else + (cons value nil))))) + (xsd:maxInclusive + (let ((value (string-to-number value))) + (setf (soap-xs-simple-type-integer-range type) + (if (soap-xs-simple-type-integer-range type) + (cons (car (soap-xs-simple-type-integer-range type)) + value) + ;; else + (cons nil value)))))))))) + +(defun soap-xs-add-union (node type) + "Add union members defined in XML NODE to TYPE, an `soap-xs-simple-type'." + (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:union) + nil + "expecting xsd:union node, got %s" (soap-l2wk (xml-node-name node))) + + (setf (soap-xs-simple-type-base type) + (mapcar 'soap-l2fq + (split-string + (or (xml-get-attribute-or-nil node 'memberTypes) "")))) + + ;; Additional simple types can be defined inside the union node. Add them + ;; to the base list. The "memberTypes" members will have to be resolved by + ;; the "resolve-references" method, the inline types will not. + (let (result) + (dolist (simple-type (soap-xml-get-children1 node 'xsd:simpleType)) + (push (soap-xs-parse-simple-type simple-type) result)) + (setf (soap-xs-simple-type-base type) + (append (soap-xs-simple-type-base type) (nreverse result))))) + +(defun soap-xs-add-list (node type) + "Add list defined in XML NODE to TYPE, a `soap-xs-simple-type'." + (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:list) + nil + "expecting xsd:list node, got %s" (soap-l2wk (xml-node-name node))) + + ;; A simple type can be defined inline inside the list node or referenced by + ;; the itemType attribute, in which case it will be resolved by the + ;; resolve-references method. + (let* ((item-type (xml-get-attribute-or-nil node 'itemType)) + (children (soap-xml-get-children1 node 'xsd:simpleType))) + (if item-type + (if (= (length children) 0) + (setf (soap-xs-simple-type-base type) (soap-l2fq item-type)) + (soap-warning + "xsd:list node with itemType has more than zero children: %s" + (soap-xs-type-name type))) + (if (= (length children) 1) + (setf (soap-xs-simple-type-base type) + (soap-xs-parse-simple-type + (car (soap-xml-get-children1 node 'xsd:simpleType)))) + (soap-warning "xsd:list node has more than one child %s" + (soap-xs-type-name type)))) + (setf (soap-xs-simple-type-is-list type) t))) + +(defun soap-xs-add-extension (node type) + "Add the extended type defined in XML NODE to TYPE, an `soap-xs-simple-type'." + (setf (soap-xs-simple-type-base type) + (soap-l2fq (xml-get-attribute node 'base))) + (dolist (attribute (soap-xml-get-children1 node 'xsd:attribute)) + (push (soap-xs-parse-attribute attribute) + (soap-xs-type-attributes type))) + (dolist (attribute-group (soap-xml-get-children1 node 'xsd:attributeGroup)) + (push (soap-xs-parse-attribute-group attribute-group) + (soap-xs-type-attribute-groups type)))) + +(defun soap-validate-xs-basic-type (value type) + "Validate VALUE against the basic type TYPE." + (let* ((kind (soap-xs-basic-type-kind type))) + (case kind + ((anyType Array byte[]) + value) + (t + (let ((convert (get kind 'rng-xsd-convert))) + (if convert + (if (rng-dt-make-value convert value) + value + (error "Invalid %s: %s" (symbol-name kind) value)) + (error "Don't know how to convert %s" kind))))))) + +(defun soap-validate-xs-simple-type (value type) + "Validate VALUE against the restrictions of TYPE." + + (let* ((base-type (soap-xs-simple-type-base type)) + (messages nil)) + (if (listp base-type) + (catch 'valid + (dolist (base base-type) + (condition-case error-object + (cond ((soap-xs-simple-type-p base) + (throw 'valid + (soap-validate-xs-simple-type value base))) + ((soap-xs-basic-type-p base) + (throw 'valid + (soap-validate-xs-basic-type value base)))) + (error (push (cadr error-object) messages)))) + (when messages + (error (mapconcat 'identity (nreverse messages) "; and: ")))) + (cl-flet ((fail-with-message (format value) + (push (format format value) messages) + (throw 'invalid nil))) + (catch 'invalid + (let ((enumeration (soap-xs-simple-type-enumeration type))) + (when (and (> (length enumeration) 1) + (not (member value enumeration))) + (fail-with-message "bad value, should be one of %s" enumeration))) + + (let ((pattern (soap-xs-simple-type-pattern type))) + (when (and pattern (not (string-match-p pattern value))) + (fail-with-message "bad value, should match pattern %s" pattern))) + + (let ((length-range (soap-xs-simple-type-length-range type))) + (when length-range + (unless (stringp value) + (fail-with-message + "bad value, should be a string with length range %s" + length-range)) + (when (car length-range) + (unless (>= (length value) (car length-range)) + (fail-with-message "short string, should be at least %s chars" + (car length-range)))) + (when (cdr length-range) + (unless (<= (length value) (cdr length-range)) + (fail-with-message "long string, should be at most %s chars" + (cdr length-range)))))) + + (let ((integer-range (soap-xs-simple-type-integer-range type))) + (when integer-range + (unless (numberp value) + (fail-with-message "bad value, should be a number with range %s" + integer-range)) + (when (car integer-range) + (unless (>= value (car integer-range)) + (fail-with-message "small value, should be at least %s" + (car integer-range)))) + (when (cdr integer-range) + (unless (<= value (cdr integer-range)) + (fail-with-message "big value, should be at most %s" + (cdr integer-range)))))))) + (when messages + (error "Xs-simple-type(%s, %s): %s" + value (or (soap-xs-type-name type) (soap-xs-type-id type)) + (car messages))))) + ;; Return the validated value. + value) + +(defun soap-resolve-references-for-xs-simple-type (type wsdl) + "Replace names in TYPE with the referenced objects in the WSDL. +This is a specialization of `soap-resolve-references' for +`soap-xs-simple-type' objects. + +See also `soap-wsdl-resolve-references'." + + (let ((namespace (soap-element-namespace-tag type))) + (when namespace + (let ((nstag (car (rassoc namespace (soap-wsdl-alias-table wsdl))))) + (when nstag + (setf (soap-element-namespace-tag type) nstag))))) + + (let ((base (soap-xs-simple-type-base type))) + (cond + ((soap-name-p base) + (setf (soap-xs-simple-type-base type) + (soap-wsdl-get base wsdl 'soap-xs-type-p))) + ((soap-xs-type-p base) + (soap-resolve-references base wsdl)) + ((listp base) + (setf (soap-xs-simple-type-base type) + (mapcar (lambda (type) + (cond ((soap-name-p type) + (soap-wsdl-get type wsdl 'soap-xs-type-p)) + ((soap-xs-type-p type) + (soap-resolve-references type wsdl) + type) + (t ; signal an error? + type))) + base))) + (t (error "Oops")))) + (dolist (attribute (soap-xs-type-attributes type)) + (soap-resolve-references attribute wsdl)) + (dolist (attribute-group (soap-xs-type-attribute-groups type)) + (soap-resolve-references attribute-group wsdl))) + +(defun soap-encode-xs-simple-type-attributes (value type) + "Encode the XML attributes for VALUE according to TYPE. +The xsi:type and an optional xsi:nil attributes are added. The +attributes are inserted in the current buffer at the current +position. + +This is a specialization of `soap-encode-attributes' for +`soap-xs-simple-type' objects." + (insert " xsi:type=\"" (soap-element-fq-name type) "\"") + (unless value (insert " xsi:nil=\"true\""))) + +(defun soap-encode-xs-simple-type (value type) + "Encode the VALUE according to TYPE. +The data is inserted in the current buffer at the current +position. + +This is a specialization of `soap-encode-value' for +`soap-xs-simple-type' objects." + (soap-validate-xs-simple-type value type) + (if (soap-xs-simple-type-is-list type) + (progn + (dolist (v (butlast value)) + (soap-encode-value v (soap-xs-simple-type-base type)) + (insert " ")) + (soap-encode-value (car (last value)) (soap-xs-simple-type-base type))) + (soap-encode-value value (soap-xs-simple-type-base type)))) + +(defun soap-decode-xs-simple-type (type node) + "Use TYPE, a `soap-xs-simple-type', to decode the contents of NODE. +A LISP value is returned based on the contents of NODE and the +type-info stored in TYPE. + +This is a specialization of `soap-decode-type' for +`soap-xs-simple-type' objects." + (if (soap-xs-simple-type-is-list type) + ;; Technically, we could construct fake XML NODEs and pass them to + ;; soap-decode-value... + (split-string (car (xml-node-children node))) + (let ((value (soap-decode-type (soap-xs-simple-type-base type) node))) + (soap-validate-xs-simple-type value type)))) + +;; Register methods for `soap-xs-simple-type' +(let ((tag (aref (make-soap-xs-simple-type) 0))) + (put tag 'soap-resolve-references + #'soap-resolve-references-for-xs-simple-type) + (put tag 'soap-attribute-encoder #'soap-encode-xs-simple-type-attributes) + (put tag 'soap-encoder #'soap-encode-xs-simple-type) + (put tag 'soap-decoder #'soap-decode-xs-simple-type)) + +;;;;; soap-xs-complex-type + +(defstruct (soap-xs-complex-type (:include soap-xs-type)) + indicator ; sequence, choice, all, array + base + elements + optional? + multiple? + is-group) + +(defun soap-xs-parse-complex-type (node) + "Construct a `soap-xs-complex-type' by parsing the XML NODE." + (let ((name (xml-get-attribute-or-nil node 'name)) + (id (xml-get-attribute-or-nil node 'id)) + (node-name (soap-l2wk (xml-node-name node))) + type + attributes + attribute-groups) + (assert (memq node-name '(xsd:complexType xsd:complexContent xsd:group)) + nil "unexpected node: %s" node-name) + + (dolist (def (xml-node-children node)) + (when (consp def) ; skip text nodes + (case (soap-l2wk (xml-node-name def)) + (xsd:attribute (push (soap-xs-parse-attribute def) attributes)) + (xsd:attributeGroup + (push (soap-xs-parse-attribute-group def) + attribute-groups)) + (xsd:simpleContent (setq type (soap-xs-parse-simple-type def))) + ((xsd:sequence xsd:all xsd:choice) + (setq type (soap-xs-parse-sequence def))) + (xsd:complexContent + (dolist (def (xml-node-children def)) + (when (consp def) + (case (soap-l2wk (xml-node-name def)) + (xsd:attribute + (push (soap-xs-parse-attribute def) attributes)) + (xsd:attributeGroup + (push (soap-xs-parse-attribute-group def) + attribute-groups)) + ((xsd:extension xsd:restriction) + (setq type + (soap-xs-parse-extension-or-restriction def))) + ((xsd:sequence xsd:all xsd:choice) + (soap-xs-parse-sequence def))))))))) + (unless type + ;; the type has not been built, this is a shortcut for a simpleContent + ;; node + (setq type (make-soap-xs-complex-type))) + + (setf (soap-xs-type-name type) name) + (setf (soap-xs-type-namespace-tag type) soap-target-xmlns) + (setf (soap-xs-type-id type) id) + (setf (soap-xs-type-attributes type) + (append attributes (soap-xs-type-attributes type))) + (setf (soap-xs-type-attribute-groups type) + (append attribute-groups (soap-xs-type-attribute-groups type))) + (when (soap-xs-complex-type-p type) + (setf (soap-xs-complex-type-is-group type) + (eq node-name 'xsd:group))) + type)) + +(defun soap-xs-parse-sequence (node) + "Parse a sequence definition from XML NODE. +Returns a `soap-xs-complex-type'" + (assert (memq (soap-l2wk (xml-node-name node)) + '(xsd:sequence xsd:choice xsd:all)) + nil + "unexpected node: %s" (soap-l2wk (xml-node-name node))) + + (let ((type (make-soap-xs-complex-type))) + + (setf (soap-xs-complex-type-indicator type) + (ecase (soap-l2wk (xml-node-name node)) + (xsd:sequence 'sequence) + (xsd:all 'all) + (xsd:choice 'choice))) + + (setf (soap-xs-complex-type-optional? type) (soap-node-optional node)) + (setf (soap-xs-complex-type-multiple? type) (soap-node-multiple node)) + + (dolist (r (xml-node-children node)) + (unless (stringp r) ; skip the white space + (case (soap-l2wk (xml-node-name r)) + ((xsd:element xsd:group) + (push (soap-xs-parse-element r) + (soap-xs-complex-type-elements type))) + ((xsd:sequence xsd:choice xsd:all) + ;; an inline sequence, choice or all node + (let ((choice (soap-xs-parse-sequence r))) + (push (make-soap-xs-element :name nil :type^ choice) + (soap-xs-complex-type-elements type)))) + (xsd:attribute + (push (soap-xs-parse-attribute r) + (soap-xs-type-attributes type))) + (xsd:attributeGroup + (push (soap-xs-parse-attribute-group r) + (soap-xs-type-attribute-groups type)))))) + + (setf (soap-xs-complex-type-elements type) + (nreverse (soap-xs-complex-type-elements type))) + + type)) + +(defun soap-xs-parse-extension-or-restriction (node) + "Parse an extension or restriction definition from XML NODE. +Return a `soap-xs-complex-type'." + (assert (memq (soap-l2wk (xml-node-name node)) + '(xsd:extension xsd:restriction)) + nil + "unexpected node: %s" (soap-l2wk (xml-node-name node))) + (let (type + attributes + attribute-groups + array? + (base (xml-get-attribute-or-nil node 'base))) + + ;; Array declarations are recognized specially, it is unclear to me how + ;; they could be treated generally... + (setq array? + (and (eq (soap-l2wk (xml-node-name node)) 'xsd:restriction) + (equal base (soap-wk2l "soapenc:Array")))) + + (dolist (def (xml-node-children node)) + (when (consp def) ; skip text nodes + (case (soap-l2wk (xml-node-name def)) + ((xsd:sequence xsd:choice xsd:all) + (setq type (soap-xs-parse-sequence def))) + (xsd:attribute + (if array? + (let ((array-type + (soap-xml-get-attribute-or-nil1 def 'wsdl:arrayType))) + (when (and array-type + (string-match "^\\(.*\\)\\[\\]$" array-type)) + ;; Override + (setq base (match-string 1 array-type)))) + ;; else + (push (soap-xs-parse-attribute def) attributes))) + (xsd:attributeGroup + (push (soap-xs-parse-attribute-group def) attribute-groups))))) + + (unless type + (setq type (make-soap-xs-complex-type)) + (when array? + (setf (soap-xs-complex-type-indicator type) 'array))) + + (setf (soap-xs-complex-type-base type) (soap-l2fq base)) + (setf (soap-xs-complex-type-attributes type) attributes) + (setf (soap-xs-complex-type-attribute-groups type) attribute-groups) + type)) + +(defun soap-resolve-references-for-xs-complex-type (type wsdl) + "Replace names in TYPE with the referenced objects in the WSDL. +This is a specialization of `soap-resolve-references' for +`soap-xs-complex-type' objects. + +See also `soap-wsdl-resolve-references'." + + (let ((namespace (soap-element-namespace-tag type))) + (when namespace + (let ((nstag (car (rassoc namespace (soap-wsdl-alias-table wsdl))))) + (when nstag + (setf (soap-element-namespace-tag type) nstag))))) + + (let ((base (soap-xs-complex-type-base type))) + (cond ((soap-name-p base) + (setf (soap-xs-complex-type-base type) + (soap-wsdl-get base wsdl 'soap-xs-type-p))) + ((soap-xs-type-p base) + (soap-resolve-references base wsdl)))) + (let (all-elements) + (dolist (element (soap-xs-complex-type-elements type)) + (if (soap-xs-element-is-group element) + ;; This is an xsd:group element that references an xsd:group node, + ;; which we treat as a complex type. We replace the reference + ;; element by inlining the elements of the referenced xsd:group + ;; (complex type) node. + (let ((type (soap-wsdl-get + (soap-xs-element-reference element) + wsdl (lambda (type) + (and + (soap-xs-complex-type-p type) + (soap-xs-complex-type-is-group type)))))) + (dolist (element (soap-xs-complex-type-elements type)) + (soap-resolve-references element wsdl) + (push element all-elements))) + ;; This is a non-xsd:group node so just add it directly. + (soap-resolve-references element wsdl) + (push element all-elements))) + (setf (soap-xs-complex-type-elements type) (nreverse all-elements))) + (dolist (attribute (soap-xs-type-attributes type)) + (soap-resolve-references attribute wsdl)) + (dolist (attribute-group (soap-xs-type-attribute-groups type)) + (soap-resolve-references attribute-group wsdl))) + +(defun soap-encode-xs-complex-type-attributes (value type) + "Encode the XML attributes for encoding VALUE according to TYPE. +The xsi:type and optional xsi:nil attributes are added, plus +additional attributes needed for arrays types, if applicable. The +attributes are inserted in the current buffer at the current +position. + +This is a specialization of `soap-encode-attributes' for +`soap-xs-complex-type' objects." + (if (eq (soap-xs-complex-type-indicator type) 'array) + (let ((element-type (soap-xs-complex-type-base type))) + (insert " xsi:type=\"soapenc:Array\"") + (insert " soapenc:arrayType=\"" + (soap-element-fq-name element-type) + "[" (format "%s" (length value)) "]" "\"")) + ;; else + (progn + (dolist (a (soap-get-xs-attributes type)) + (let ((element-name (soap-element-name a))) + (if (soap-xs-attribute-default a) + (insert " " element-name + "=\"" (soap-xs-attribute-default a) "\"") + (dolist (value-pair value) + (when (equal element-name (symbol-name (car value-pair))) + (insert " " element-name + "=\"" (cdr value-pair) "\"")))))) + ;; If this is not an empty type, and we have no value, mark it as nil + (when (and (soap-xs-complex-type-indicator type) (null value)) + (insert " xsi:nil=\"true\""))))) + +(defun soap-get-candidate-elements (element) + "Return a list of elements that are compatible with ELEMENT. +The returned list includes ELEMENT's references and +alternatives." + (let ((reference (soap-xs-element-reference element))) + ;; If the element is a reference, append the reference and its + ;; alternatives... + (if reference + (append (list reference) + (soap-xs-element-alternatives reference)) + ;; ...otherwise append the element itself and its alternatives. + (append (list element) + (soap-xs-element-alternatives element))))) + +(defun soap-encode-xs-complex-type (value type) + "Encode the VALUE according to TYPE. +The data is inserted in the current buffer at the current +position. + +This is a specialization of `soap-encode-value' for +`soap-xs-complex-type' objects." + (case (soap-xs-complex-type-indicator type) + (array + (error "soap-encode-xs-complex-type arrays are handled elsewhere")) + ((sequence choice all nil) + (let ((type-list (list type))) + + ;; Collect all base types + (let ((base (soap-xs-complex-type-base type))) + (while base + (push base type-list) + (setq base (soap-xs-complex-type-base base)))) + + (dolist (type type-list) + (dolist (element (soap-xs-complex-type-elements type)) + (catch 'done + (let ((instance-count 0)) + (dolist (candidate (soap-get-candidate-elements element)) + (let ((e-name (soap-xs-element-name candidate))) + (if e-name + (let ((e-name (intern e-name))) + (dolist (v value) + (when (equal (car v) e-name) + (incf instance-count) + (soap-encode-value (cdr v) candidate)))) + (if (soap-xs-complex-type-indicator type) + (let ((current-point (point))) + ;; Check if encoding happened by checking if + ;; characters were inserted in the buffer. + (soap-encode-value value candidate) + (when (not (equal current-point (point))) + (incf instance-count))) + (dolist (v value) + (let ((current-point (point))) + (soap-encode-value v candidate) + (when (not (equal current-point (point))) + (incf instance-count)))))))) + ;; Do some sanity checking + (let* ((indicator (soap-xs-complex-type-indicator type)) + (element-type (soap-xs-element-type element)) + (reference (soap-xs-element-reference element)) + (e-name (or (soap-xs-element-name element) + (and reference + (soap-xs-element-name reference))))) + (cond ((and (eq indicator 'choice) + (> instance-count 0)) + ;; This was a choice node and we encoded + ;; one instance. + (throw 'done t)) + ((and (not (eq indicator 'choice)) + (= instance-count 0) + (not (soap-xs-element-optional? element)) + (and (soap-xs-complex-type-p element-type) + (not (soap-xs-complex-type-optional-p + element-type)))) + (soap-warning + "While encoding %s: missing non-nillable slot %s" + value e-name)) + ((and (> instance-count 1) + (not (soap-xs-element-multiple? element)) + (and (soap-xs-complex-type-p element-type) + (not (soap-xs-complex-type-multiple-p + element-type)))) + (soap-warning + (concat "While encoding %s: expected single," + " found multiple elements for slot %s") + value e-name)))))))))) + (t + (error "Don't know how to encode complex type: %s" + (soap-xs-complex-type-indicator type))))) + +(defun soap-xml-get-children-fq (node child-name) + "Return the children of NODE named CHILD-NAME. +This is the same as `xml-get-children1', but NODE's local +namespace is used to resolve the children's namespace tags." + (let (result) + (dolist (c (xml-node-children node)) + (when (and (consp c) + (soap-with-local-xmlns node + ;; We use `ignore-errors' here because we want to silently + ;; skip nodes for which we cannot convert them to a + ;; well-known name. + (equal (ignore-errors + (soap-l2fq (xml-node-name c))) + child-name))) + (push c result))) + (nreverse result))) + +(defun soap-xs-element-get-fq-name (element wsdl) + "Return ELEMENT's fully-qualified name using WSDL's alias table. +Return nil if ELEMENT does not have a name." + (let* ((ns-aliases (soap-wsdl-alias-table wsdl)) + (ns-name (cdr (assoc + (soap-element-namespace-tag element) + ns-aliases)))) + (when ns-name + (cons ns-name (soap-element-name element))))) + +(defun soap-xs-complex-type-optional-p (type) + "Return t if TYPE or any of TYPE's ancestor types is optional. +Return nil otherwise." + (when type + (or (soap-xs-complex-type-optional? type) + (and (soap-xs-complex-type-p type) + (soap-xs-complex-type-optional-p + (soap-xs-complex-type-base type)))))) + +(defun soap-xs-complex-type-multiple-p (type) + "Return t if TYPE or any of TYPE's ancestor types permits multiple elements. +Return nil otherwise." + (when type + (or (soap-xs-complex-type-multiple? type) + (and (soap-xs-complex-type-p type) + (soap-xs-complex-type-multiple-p + (soap-xs-complex-type-base type)))))) + +(defun soap-get-xs-attributes-from-groups (attribute-groups) + "Return a list of attributes from all ATTRIBUTE-GROUPS." + (let (attributes) + (dolist (group attribute-groups) + (let ((sub-groups (soap-xs-attribute-group-attribute-groups group))) + (setq attributes (append attributes + (soap-get-xs-attributes-from-groups sub-groups) + (soap-xs-attribute-group-attributes group))))) + attributes)) + +(defun soap-get-xs-attributes (type) + "Return a list of all of TYPE's and TYPE's ancestors' attributes." + (let* ((base (and (soap-xs-complex-type-p type) + (soap-xs-complex-type-base type))) + (attributes (append (soap-xs-type-attributes type) + (soap-get-xs-attributes-from-groups + (soap-xs-type-attribute-groups type))))) + (if base + (append attributes (soap-get-xs-attributes base)) + attributes))) + +(defun soap-decode-xs-attributes (type node) + "Use TYPE, a `soap-xs-complex-type', to decode the attributes of NODE." + (let (result) + (dolist (attribute (soap-get-xs-attributes type)) + (let* ((name (soap-xs-attribute-name attribute)) + (attribute-type (soap-xs-attribute-type attribute)) + (symbol (intern name)) + (value (xml-get-attribute-or-nil node symbol))) + ;; We don't support attribute uses: required, optional, prohibited. + (cond + ((soap-xs-basic-type-p attribute-type) + ;; Basic type values are validated by xml.el. + (when value + (push (cons symbol + ;; Create a fake XML node to satisfy the + ;; soap-decode-xs-basic-type API. + (soap-decode-xs-basic-type attribute-type + (list symbol nil value))) + result))) + ((soap-xs-simple-type-p attribute-type) + (when value + (push (cons symbol + (soap-validate-xs-simple-type value attribute-type)) + result))) + (t + (error (concat "Attribute %s is of type %s which is" + " not a basic or simple type") + name (soap-name-p attribute)))))) + result)) + +(defun soap-decode-xs-complex-type (type node) + "Use TYPE, a `soap-xs-complex-type', to decode the contents of NODE. +A LISP value is returned based on the contents of NODE and the +type-info stored in TYPE. + +This is a specialization of `soap-decode-type' for +`soap-xs-basic-type' objects." + (case (soap-xs-complex-type-indicator type) + (array + (let ((result nil) + (element-type (soap-xs-complex-type-base type))) + (dolist (node (xml-node-children node)) + (when (consp node) + (push (soap-decode-type element-type node) result))) + (nreverse result))) + ((sequence choice all nil) + (let ((result nil) + (base (soap-xs-complex-type-base type))) + (when base + (setq result (nreverse (soap-decode-type base node)))) + (catch 'done + (dolist (element (soap-xs-complex-type-elements type)) + (let* ((instance-count 0) + (e-name (soap-xs-element-name element)) + ;; Heuristic: guess if we need to decode using local + ;; namespaces. + (use-fq-names (string-match ":" (symbol-name (car node)))) + (children (if e-name + (if use-fq-names + ;; Find relevant children + ;; using local namespaces by + ;; searching for the element's + ;; fully-qualified name. + (soap-xml-get-children-fq + node + (soap-xs-element-get-fq-name + element soap-current-wsdl)) + ;; No local namespace resolution + ;; needed so use the element's + ;; name unqualified. + (xml-get-children node (intern e-name))) + ;; e-name is nil so a) we don't know which + ;; children to operate on, and b) we want to + ;; re-use soap-decode-xs-complex-type, which + ;; expects a node argument with a complex + ;; type; therefore we need to operate on the + ;; entire node. We wrap node in a list so + ;; that it will carry through as "node" in the + ;; loop below. + ;; + ;; For example: + ;; + ;; Element Type: + ;; <xs:complexType name="A"> + ;; <xs:sequence> + ;; <xs:element name="B" type="t:BType"/> + ;; <xs:choice> + ;; <xs:element name="C" type="xs:string"/> + ;; <xs:element name="D" type="t:DType"/> + ;; </xs:choice> + ;; </xs:sequence> + ;; </xs:complexType> + ;; + ;; Node: + ;; <t:A> + ;; <t:B tag="b"/> + ;; <t:C>1</C> + ;; </t:A> + ;; + ;; soap-decode-type will be called below with: + ;; + ;; element = + ;; <xs:choice> + ;; <xs:element name="C" type="xs:string"/> + ;; <xs:element name="D" type="t:DType"/> + ;; </xs:choice> + ;; node = + ;; <t:A> + ;; <t:B tag="b"/> + ;; <t:C>1</C> + ;; </t:A> + (list node))) + (element-type (soap-xs-element-type element))) + (dolist (node children) + (incf instance-count) + (let* ((attributes + (soap-decode-xs-attributes element-type node)) + ;; Attributes may specify xsi:type override. + (element-type + (if (soap-xml-get-attribute-or-nil1 node 'xsi:type) + (soap-wsdl-get + (soap-l2fq + (soap-xml-get-attribute-or-nil1 node + 'xsi:type)) + soap-current-wsdl 'soap-xs-type-p t) + element-type)) + (decoded-child (soap-decode-type element-type node))) + (if e-name + (push (cons (intern e-name) + (append attributes decoded-child)) result) + ;; When e-name is nil we don't want to introduce an extra + ;; level of nesting, so we splice the decoding into + ;; result. + (setq result (append decoded-child result))))) + (cond ((and (eq (soap-xs-complex-type-indicator type) 'choice) + ;; Choices can allow multiple values. + (not (soap-xs-complex-type-multiple-p type)) + (> instance-count 0)) + ;; This was a choice node, and we decoded one value. + (throw 'done t)) + + ;; Do some sanity checking + ((and (not (eq (soap-xs-complex-type-indicator type) + 'choice)) + (= instance-count 0) + (not (soap-xs-element-optional? element)) + (and (soap-xs-complex-type-p element-type) + (not (soap-xs-complex-type-optional-p + element-type)))) + (soap-warning "missing non-nillable slot %s" e-name)) + ((and (> instance-count 1) + (not (soap-xs-complex-type-multiple-p type)) + (not (soap-xs-element-multiple? element)) + (and (soap-xs-complex-type-p element-type) + (not (soap-xs-complex-type-multiple-p + element-type)))) + (soap-warning "expected single %s slot, found multiple" + e-name)))))) + (nreverse result))) + (t + (error "Don't know how to decode complex type: %s" + (soap-xs-complex-type-indicator type))))) + +;; Register methods for `soap-xs-complex-type' +(let ((tag (aref (make-soap-xs-complex-type) 0))) + (put tag 'soap-resolve-references + #'soap-resolve-references-for-xs-complex-type) + (put tag 'soap-attribute-encoder #'soap-encode-xs-complex-type-attributes) + (put tag 'soap-encoder #'soap-encode-xs-complex-type) + (put tag 'soap-decoder #'soap-decode-xs-complex-type)) + +;;;; WSDL documents +;;;;; WSDL document elements + + (defstruct (soap-message (:include soap-element)) parts ; ALIST of NAME => WSDL-TYPE name ) @@ -392,7 +1945,9 @@ binding) but the same name." parameter-order input ; (NAME . MESSAGE) output ; (NAME . MESSAGE) - faults) ; a list of (NAME . MESSAGE) + faults ; a list of (NAME . MESSAGE) + input-action ; WS-addressing action string + output-action) ; WS-addressing action string (defstruct (soap-port-type (:include soap-element)) operations) ; a namespace of operations @@ -403,8 +1958,10 @@ binding) but the same name." (defstruct soap-bound-operation operation ; SOAP-OPERATION soap-action ; value for SOAPAction HTTP header + soap-headers ; list of (message part use) + soap-body ; message parts present in the body use ; 'literal or 'encoded, see - ; http://www.w3.org/TR/wsdl#_soap:body + ; http://www.w3.org/TR/wsdl#_soap:body ) (defstruct (soap-binding (:include soap-element)) @@ -415,49 +1972,49 @@ binding) but the same name." service-url binding) -(defun soap-default-xsd-types () - "Return a namespace containing some of the XMLSchema types." - (let ((ns (make-soap-namespace :name "http://www.w3.org/2001/XMLSchema"))) - (dolist (type '("string" "dateTime" "boolean" - "long" "int" "integer" "unsignedInt" "byte" "float" "double" - "base64Binary" "anyType" "anyURI" "Array" "byte[]")) - (soap-namespace-put - (make-soap-basic-type :name type :kind (intern type)) - ns)) - ns)) - -(defun soap-default-soapenc-types () - "Return a namespace containing some of the SOAPEnc types." - (let ((ns (make-soap-namespace - :name "http://schemas.xmlsoap.org/soap/encoding/"))) - (dolist (type '("string" "dateTime" "boolean" - "long" "int" "integer" "unsignedInt" "byte" "float" "double" - "base64Binary" "anyType" "anyURI" "Array" "byte[]")) - (soap-namespace-put - (make-soap-basic-type :name type :kind (intern type)) - ns)) - ns)) - -(defun soap-type-p (element) - "Return t if ELEMENT is a SOAP data type (basic or complex)." - (or (soap-basic-type-p element) - (soap-sequence-type-p element) - (soap-array-type-p element))) - ;;;;; The WSDL document ;; The WSDL data structure used for encoding/decoding SOAP messages -(defstruct soap-wsdl +(defstruct (soap-wsdl + ;; NOTE: don't call this constructor, see `soap-make-wsdl' + (:constructor soap-make-wsdl^) + (:copier soap-copy-wsdl)) origin ; file or URL from which this wsdl was loaded + current-file ; most-recently fetched file or URL + xmlschema-imports ; a list of schema imports ports ; a list of SOAP-PORT instances alias-table ; a list of namespace aliases namespaces ; a list of namespaces ) +(defun soap-make-wsdl (origin) + "Create a new WSDL document, loaded from ORIGIN, and intialize it." + (let ((wsdl (soap-make-wsdl^ :origin origin))) + + ;; Add the XSD types to the wsdl document + (let ((ns (soap-make-xs-basic-types + "http://www.w3.org/2001/XMLSchema" "xsd"))) + (soap-wsdl-add-namespace ns wsdl) + (soap-wsdl-add-alias "xsd" (soap-namespace-name ns) wsdl)) + + ;; Add the soapenc types to the wsdl document + (let ((ns (soap-make-xs-basic-types + "http://schemas.xmlsoap.org/soap/encoding/" "soapenc"))) + (soap-wsdl-add-namespace ns wsdl) + (soap-wsdl-add-alias "soapenc" (soap-namespace-name ns) wsdl)) + + wsdl)) + (defun soap-wsdl-add-alias (alias name wsdl) "Add a namespace ALIAS for NAME to the WSDL document." - (push (cons alias name) (soap-wsdl-alias-table wsdl))) + (let ((existing (assoc alias (soap-wsdl-alias-table wsdl)))) + (if existing + (unless (equal (cdr existing) name) + (warn "Redefining alias %s from %s to %s" + alias (cdr existing) name) + (push (cons alias name) (soap-wsdl-alias-table wsdl))) + (push (cons alias name) (soap-wsdl-alias-table wsdl))))) (defun soap-wsdl-find-namespace (name wsdl) "Find a namespace by NAME in the WSDL document." @@ -473,11 +2030,11 @@ elements will be added to it." (let ((existing (soap-wsdl-find-namespace (soap-namespace-name ns) wsdl))) (if existing ;; Add elements from NS to EXISTING, replacing existing values. - (maphash (lambda (key value) + (maphash (lambda (_key value) (dolist (v value) (soap-namespace-put v existing))) (soap-namespace-elements ns)) - (push ns (soap-wsdl-namespaces wsdl))))) + (push ns (soap-wsdl-namespaces wsdl))))) (defun soap-wsdl-get (name wsdl &optional predicate use-local-alias-table) "Retrieve element NAME from the WSDL document. @@ -488,9 +2045,9 @@ structure predicate for the type of element you want to retrieve. For example, to retrieve a message named \"foo\" when other elements named \"foo\" exist in the WSDL you could use: - (soap-wsdl-get \"foo\" WSDL 'soap-message-p) + (soap-wsdl-get \"foo\" WSDL \\='soap-message-p) -If USE-LOCAL-ALIAS-TABLE is not nil, `soap-local-xmlns` will be +If USE-LOCAL-ALIAS-TABLE is not nil, `soap-local-xmlns' will be used to resolve the namespace alias." (let ((alias-table (soap-wsdl-alias-table wsdl)) namespace element-name element) @@ -516,13 +2073,13 @@ used to resolve the namespace alias." (ns-name (cdr (assoc ns-alias alias-table)))) (unless ns-name (error "Soap-wsdl-get(%s): cannot find namespace alias %s" - name ns-alias)) + name ns-alias)) (setq namespace (soap-wsdl-find-namespace ns-name wsdl)) (unless namespace (error - "Soap-wsdl-get(%s): unknown namespace %s, referenced by alias %s" - name ns-name ns-alias)))) + "Soap-wsdl-get(%s): unknown namespace %s, referenced as %s" + name ns-name ns-alias)))) (t (error "Soap-wsdl-get(%s): bad name" name))) @@ -532,7 +2089,7 @@ used to resolve the namespace alias." (lambda (e) (or (funcall 'soap-namespace-link-p e) (funcall predicate e))) - nil))) + nil))) (unless element (error "Soap-wsdl-get(%s): cannot find element" name)) @@ -540,92 +2097,96 @@ used to resolve the namespace alias." (if (soap-namespace-link-p element) ;; NOTE: don't use the local alias table here (soap-wsdl-get (soap-namespace-link-target element) wsdl predicate) - element))) + element))) + +;;;;; soap-parse-schema + +(defun soap-parse-schema (node wsdl) + "Parse a schema NODE, placing the results in WSDL. +Return a SOAP-NAMESPACE containing the elements." + (soap-with-local-xmlns node + (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:schema) + nil + "expecting an xsd:schema node, got %s" + (soap-l2wk (xml-node-name node))) + + (let ((ns (make-soap-namespace :name (soap-get-target-namespace node)))) + + (dolist (def (xml-node-children node)) + (unless (stringp def) ; skip text nodes + (case (soap-l2wk (xml-node-name def)) + (xsd:import + ;; Imports will be processed later + ;; NOTE: we should expand the location now! + (let ((location (or + (xml-get-attribute-or-nil def 'schemaLocation) + (xml-get-attribute-or-nil def 'location)))) + (when location + (push location (soap-wsdl-xmlschema-imports wsdl))))) + (xsd:element + (soap-namespace-put (soap-xs-parse-element def) ns)) + (xsd:attribute + (soap-namespace-put (soap-xs-parse-attribute def) ns)) + (xsd:attributeGroup + (soap-namespace-put (soap-xs-parse-attribute-group def) ns)) + (xsd:simpleType + (soap-namespace-put (soap-xs-parse-simple-type def) ns)) + ((xsd:complexType xsd:group) + (soap-namespace-put (soap-xs-parse-complex-type def) ns))))) + ns))) ;;;;; Resolving references for wsdl types ;; See `soap-wsdl-resolve-references', which is the main entry point for ;; resolving references -(defun soap-resolve-references-for-element (element wsdl) - "Resolve references in ELEMENT using the WSDL document. -This is a generic function which invokes a specific function -depending on the element type. +(defun soap-resolve-references (element wsdl) + "Replace names in ELEMENT with the referenced objects in the WSDL. +This is a generic function which invokes a specific resolver +function depending on the type of the ELEMENT. -If ELEMENT has no resolver function, it is silently ignored. - -All references are resolved in-place, that is the ELEMENT is -updated." +If ELEMENT has no resolver function, it is silently ignored." (let ((resolver (get (aref element 0) 'soap-resolve-references))) (when resolver (funcall resolver element wsdl)))) -(defun soap-resolve-references-for-simple-type (type wsdl) - "Resolve the base type for the simple TYPE using the WSDL - document." - (let ((kind (soap-basic-type-kind type))) - (unless (symbolp kind) - (let ((basic-type (soap-wsdl-get kind wsdl 'soap-basic-type-p))) - (setf (soap-basic-type-kind type) - (soap-basic-type-kind basic-type)))))) - -(defun soap-resolve-references-for-sequence-type (type wsdl) - "Resolve references for a sequence TYPE using WSDL document. -See also `soap-resolve-references-for-element' and -`soap-wsdl-resolve-references'" - (let ((parent (soap-sequence-type-parent type))) - (when (or (consp parent) (stringp parent)) - (setf (soap-sequence-type-parent type) - (soap-wsdl-get - parent wsdl - ;; Prevent self references, see Bug#9 - (lambda (e) (and (not (eq e type)) (soap-type-p e))))))) - (dolist (element (soap-sequence-type-elements type)) - (let ((element-type (soap-sequence-element-type element))) - (cond ((or (consp element-type) (stringp element-type)) - (setf (soap-sequence-element-type element) - (soap-wsdl-get - element-type wsdl - ;; Prevent self references, see Bug#9 - (lambda (e) (and (not (eq e type)) (soap-type-p e)))))) - ((soap-element-p element-type) - ;; since the element already has a child element, it - ;; could be an inline structure. we must resolve - ;; references in it, because it might not be reached by - ;; scanning the wsdl names. - (soap-resolve-references-for-element element-type wsdl)))))) - -(defun soap-resolve-references-for-array-type (type wsdl) - "Resolve references for an array TYPE using WSDL. -See also `soap-resolve-references-for-element' and -`soap-wsdl-resolve-references'" - (let ((element-type (soap-array-type-element-type type))) - (when (or (consp element-type) (stringp element-type)) - (setf (soap-array-type-element-type type) - (soap-wsdl-get - element-type wsdl - ;; Prevent self references, see Bug#9 - (lambda (e) (and (not (eq e type)) (soap-type-p e)))))))) - (defun soap-resolve-references-for-message (message wsdl) - "Resolve references for a MESSAGE type using the WSDL document. -See also `soap-resolve-references-for-element' and -`soap-wsdl-resolve-references'" + "Replace names in MESSAGE with the referenced objects in the WSDL. +This is a generic function, called by `soap-resolve-references', +you should use that function instead. + +See also `soap-wsdl-resolve-references'." (let (resolved-parts) (dolist (part (soap-message-parts message)) (let ((name (car part)) - (type (cdr part))) + (element (cdr part))) (when (stringp name) (setq name (intern name))) - (when (or (consp type) (stringp type)) - (setq type (soap-wsdl-get type wsdl 'soap-type-p))) - (push (cons name type) resolved-parts))) - (setf (soap-message-parts message) (nreverse resolved-parts)))) + (if (soap-name-p element) + (setq element (soap-wsdl-get + element wsdl + (lambda (x) + (or (soap-xs-type-p x) (soap-xs-element-p x))))) + ;; else, inline element, resolve recursively, as the element + ;; won't be reached. + (soap-resolve-references element wsdl) + (unless (soap-element-namespace-tag element) + (setf (soap-element-namespace-tag element) + (soap-element-namespace-tag message)))) + (push (cons name element) resolved-parts))) + (setf (soap-message-parts message) (nreverse resolved-parts)))) (defun soap-resolve-references-for-operation (operation wsdl) "Resolve references for an OPERATION type using the WSDL document. -See also `soap-resolve-references-for-element' and +See also `soap-resolve-references' and `soap-wsdl-resolve-references'" + + (let ((namespace (soap-element-namespace-tag operation))) + (when namespace + (let ((nstag (car (rassoc namespace (soap-wsdl-alias-table wsdl))))) + (when nstag + (setf (soap-element-namespace-tag operation) nstag))))) + (let ((input (soap-operation-input operation)) (counter 0)) (let ((name (car input)) @@ -633,10 +2194,10 @@ See also `soap-resolve-references-for-element' and ;; Name this part if it was not named (when (or (null name) (equal name "")) (setq name (format "in%d" (incf counter)))) - (when (or (consp message) (stringp message)) + (when (soap-name-p message) (setf (soap-operation-input operation) (cons (intern name) - (soap-wsdl-get message wsdl 'soap-message-p)))))) + (soap-wsdl-get message wsdl 'soap-message-p)))))) (let ((output (soap-operation-output operation)) (counter 0)) @@ -644,10 +2205,10 @@ See also `soap-resolve-references-for-element' and (message (cdr output))) (when (or (null name) (equal name "")) (setq name (format "out%d" (incf counter)))) - (when (or (consp message) (stringp message)) + (when (soap-name-p message) (setf (soap-operation-output operation) (cons (intern name) - (soap-wsdl-get message wsdl 'soap-message-p)))))) + (soap-wsdl-get message wsdl 'soap-message-p)))))) (let ((resolved-faults nil) (counter 0)) @@ -656,11 +2217,11 @@ See also `soap-resolve-references-for-element' and (message (cdr fault))) (when (or (null name) (equal name "")) (setq name (format "fault%d" (incf counter)))) - (if (or (consp message) (stringp message)) + (if (soap-name-p message) (push (cons (intern name) - (soap-wsdl-get message wsdl 'soap-message-p)) + (soap-wsdl-get message wsdl 'soap-message-p)) resolved-faults) - (push fault resolved-faults)))) + (push fault resolved-faults)))) (setf (soap-operation-faults operation) resolved-faults)) (when (= (length (soap-operation-parameter-order operation)) 0) @@ -672,42 +2233,44 @@ See also `soap-resolve-references-for-element' and (mapcar (lambda (p) (if (stringp p) (intern p) - p)) + p)) (soap-operation-parameter-order operation)))) (defun soap-resolve-references-for-binding (binding wsdl) - "Resolve references for a BINDING type using the WSDL document. -See also `soap-resolve-references-for-element' and + "Resolve references for a BINDING type using the WSDL document. +See also `soap-resolve-references' and `soap-wsdl-resolve-references'" - (when (or (consp (soap-binding-port-type binding)) - (stringp (soap-binding-port-type binding))) + (when (soap-name-p (soap-binding-port-type binding)) (setf (soap-binding-port-type binding) (soap-wsdl-get (soap-binding-port-type binding) - wsdl 'soap-port-type-p))) + wsdl 'soap-port-type-p))) (let ((port-ops (soap-port-type-operations (soap-binding-port-type binding)))) (maphash (lambda (k v) (setf (soap-bound-operation-operation v) - (soap-namespace-get k port-ops 'soap-operation-p))) + (soap-namespace-get k port-ops 'soap-operation-p)) + (let (resolved-headers) + (dolist (h (soap-bound-operation-soap-headers v)) + (push (list (soap-wsdl-get (nth 0 h) wsdl) + (intern (nth 1 h)) + (nth 2 h)) + resolved-headers)) + (setf (soap-bound-operation-soap-headers v) + (nreverse resolved-headers)))) (soap-binding-operations binding)))) (defun soap-resolve-references-for-port (port wsdl) - "Resolve references for a PORT type using the WSDL document. -See also `soap-resolve-references-for-element' and -`soap-wsdl-resolve-references'" - (when (or (consp (soap-port-binding port)) - (stringp (soap-port-binding port))) + "Replace names in PORT with the referenced objects in the WSDL. +This is a generic function, called by `soap-resolve-references', +you should use that function instead. + +See also `soap-wsdl-resolve-references'." + (when (soap-name-p (soap-port-binding port)) (setf (soap-port-binding port) (soap-wsdl-get (soap-port-binding port) wsdl 'soap-binding-p)))) ;; Install resolvers for our types (progn - (put (aref (make-soap-simple-type) 0) 'soap-resolve-references - 'soap-resolve-references-for-simple-type) - (put (aref (make-soap-sequence-type) 0) 'soap-resolve-references - 'soap-resolve-references-for-sequence-type) - (put (aref (make-soap-array-type) 0) 'soap-resolve-references - 'soap-resolve-references-for-array-type) (put (aref (make-soap-message) 0) 'soap-resolve-references 'soap-resolve-references-for-message) (put (aref (make-soap-operation) 0) 'soap-resolve-references @@ -744,312 +2307,173 @@ traverse an element tree." (soap-wsdl-add-alias nstag (soap-namespace-name ns) wsdl) (throw 'done t))))) - (maphash (lambda (name element) + (maphash (lambda (_name element) (cond ((soap-element-p element) ; skip links (incf nprocessed) - (soap-resolve-references-for-element element wsdl) - (setf (soap-element-namespace-tag element) nstag)) + (soap-resolve-references element wsdl)) ((listp element) (dolist (e element) (when (soap-element-p e) (incf nprocessed) - (soap-resolve-references-for-element e wsdl) - (setf (soap-element-namespace-tag e) nstag)))))) + (soap-resolve-references e wsdl)))))) (soap-namespace-elements ns))))) - wsdl) + wsdl) ;;;;; Loading WSDL from XML documents -(defun soap-load-wsdl-from-url (url) - "Load a WSDL document from URL and return it. -The returned WSDL document needs to be used for `soap-invoke' -calls." - (let ((url-request-method "GET") +(defun soap-parse-server-response () + "Error-check and parse the XML contents of the current buffer." + (let ((mime-part (mm-dissect-buffer t t))) + (unless mime-part + (error "Failed to decode response from server")) + (unless (equal (car (mm-handle-type mime-part)) "text/xml") + (error "Server response is not an XML document")) + (with-temp-buffer + (mm-insert-part mime-part) + (prog1 + (car (xml-parse-region (point-min) (point-max))) + (kill-buffer) + (mm-destroy-part mime-part))))) + +(defun soap-fetch-xml-from-url (url wsdl) + "Load an XML document from URL and return it. +The previously parsed URL is read from WSDL." + (message "Fetching from %s" url) + (let ((current-file (url-expand-file-name url (soap-wsdl-current-file wsdl))) + (url-request-method "GET") (url-package-name "soap-client.el") (url-package-version "1.0") (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5") - (url-request-coding-system 'utf-8) - (url-http-attempt-keepalives nil)) - (let ((buffer (url-retrieve-synchronously url))) + (url-http-attempt-keepalives t)) + (setf (soap-wsdl-current-file wsdl) current-file) + (let ((buffer (url-retrieve-synchronously current-file))) (with-current-buffer buffer (declare (special url-http-response-status)) (if (> url-http-response-status 299) (error "Error retrieving WSDL: %s" url-http-response-status)) - (let ((mime-part (mm-dissect-buffer t t))) - (unless mime-part - (error "Failed to decode response from server")) - (unless (equal (car (mm-handle-type mime-part)) "text/xml") - (error "Server response is not an XML document")) - (with-temp-buffer - (mm-insert-part mime-part) - (let ((wsdl-xml (car (xml-parse-region (point-min) (point-max))))) - (prog1 - (let ((wsdl (soap-parse-wsdl wsdl-xml))) - (setf (soap-wsdl-origin wsdl) url) - wsdl) - (kill-buffer buffer))))))))) - -(defun soap-load-wsdl (file) - "Load a WSDL document from FILE and return it." - (with-temp-buffer - (insert-file-contents file) - (let ((xml (car (xml-parse-region (point-min) (point-max))))) - (let ((wsdl (soap-parse-wsdl xml))) - (setf (soap-wsdl-origin wsdl) file) - wsdl)))) - -(defun soap-parse-wsdl (node) - "Construct a WSDL structure from NODE, which is an XML document." + (soap-parse-server-response))))) + +(defun soap-fetch-xml-from-file (file wsdl) + "Load an XML document from FILE and return it. +The previously parsed file is read from WSDL." + (let* ((current-file (soap-wsdl-current-file wsdl)) + (expanded-file (expand-file-name file + (if current-file + (file-name-directory current-file) + default-directory)))) + (setf (soap-wsdl-current-file wsdl) expanded-file) + (with-temp-buffer + (insert-file-contents expanded-file) + (car (xml-parse-region (point-min) (point-max)))))) + +(defun soap-fetch-xml (file-or-url wsdl) + "Load an XML document from FILE-OR-URL and return it. +The previously parsed file or URL is read from WSDL." + (let ((current-file (or (soap-wsdl-current-file wsdl) file-or-url))) + (if (or (and current-file (file-exists-p current-file)) + (file-exists-p file-or-url)) + (soap-fetch-xml-from-file file-or-url wsdl) + (soap-fetch-xml-from-url file-or-url wsdl)))) + +(defun soap-load-wsdl (file-or-url &optional wsdl) + "Load a document from FILE-OR-URL and return it. +Build on WSDL if it is provided." + (let* ((wsdl (or wsdl (soap-make-wsdl file-or-url))) + (xml (soap-fetch-xml file-or-url wsdl))) + (soap-wsdl-resolve-references (soap-parse-wsdl xml wsdl)) + wsdl)) + +(defalias 'soap-load-wsdl-from-url 'soap-load-wsdl) + +(defun soap-parse-wsdl-phase-validate-node (node) + "Assert that NODE is valid." (soap-with-local-xmlns node + (let ((node-name (soap-l2wk (xml-node-name node)))) + (assert (eq node-name 'wsdl:definitions) + nil + "expecting wsdl:definitions node, got %s" node-name)))) - (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:definitions) - nil - "soap-parse-wsdl: expecting wsdl:definitions node, got %s" - (soap-l2wk (xml-node-name node))) - - (let ((wsdl (make-soap-wsdl))) - - ;; Add the local alias table to the wsdl document -- it will be used for - ;; all types in this document even after we finish parsing it. - (setf (soap-wsdl-alias-table wsdl) soap-local-xmlns) - - ;; Add the XSD types to the wsdl document - (let ((ns (soap-default-xsd-types))) - (soap-wsdl-add-namespace ns wsdl) - (soap-wsdl-add-alias "xsd" (soap-namespace-name ns) wsdl)) - - ;; Add the soapenc types to the wsdl document - (let ((ns (soap-default-soapenc-types))) - (soap-wsdl-add-namespace ns wsdl) - (soap-wsdl-add-alias "soapenc" (soap-namespace-name ns) wsdl)) - - ;; Find all the 'xsd:schema nodes which are children of wsdl:types nodes - ;; and build our type-library - - (let ((types (car (soap-xml-get-children1 node 'wsdl:types)))) - (dolist (node (xml-node-children types)) - ;; We cannot use (xml-get-children node (soap-wk2l 'xsd:schema)) - ;; because each node can install its own alias type so the schema - ;; nodes might have a different prefix. - (when (consp node) - (soap-with-local-xmlns node - (when (eq (soap-l2wk (xml-node-name node)) 'xsd:schema) - (soap-wsdl-add-namespace (soap-parse-schema node) wsdl)))))) - - (let ((ns (make-soap-namespace :name (soap-get-target-namespace node)))) - (dolist (node (soap-xml-get-children1 node 'wsdl:message)) - (soap-namespace-put (soap-parse-message node) ns)) - - (dolist (node (soap-xml-get-children1 node 'wsdl:portType)) - (let ((port-type (soap-parse-port-type node))) - (soap-namespace-put port-type ns) - (soap-wsdl-add-namespace - (soap-port-type-operations port-type) wsdl))) - - (dolist (node (soap-xml-get-children1 node 'wsdl:binding)) - (soap-namespace-put (soap-parse-binding node) ns)) - - (dolist (node (soap-xml-get-children1 node 'wsdl:service)) - (dolist (node (soap-xml-get-children1 node 'wsdl:port)) - (let ((name (xml-get-attribute node 'name)) - (binding (xml-get-attribute node 'binding)) - (url (let ((n (car (soap-xml-get-children1 - node 'wsdlsoap:address)))) - (xml-get-attribute n 'location)))) - (let ((port (make-soap-port - :name name :binding (soap-l2fq binding 'tns) - :service-url url))) - (soap-namespace-put port ns) - (push port (soap-wsdl-ports wsdl)))))) - - (soap-wsdl-add-namespace ns wsdl)) - - (soap-wsdl-resolve-references wsdl) - - wsdl))) - -(defun soap-parse-schema (node) - "Parse a schema NODE. -Return a SOAP-NAMESPACE containing the elements." +(defun soap-parse-wsdl-phase-fetch-imports (node wsdl) + "Fetch and load files imported by NODE into WSDL." (soap-with-local-xmlns node - (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:schema) - nil - "soap-parse-schema: expecting an xsd:schema node, got %s" - (soap-l2wk (xml-node-name node))) - (let ((ns (make-soap-namespace :name (soap-get-target-namespace node)))) - ;; NOTE: we only extract the complexTypes from the schema, we wouldn't - ;; know how to handle basic types beyond the built in ones anyway. - (dolist (node (soap-xml-get-children1 node 'xsd:simpleType)) - (soap-namespace-put (soap-parse-simple-type node) ns)) - - (dolist (node (soap-xml-get-children1 node 'xsd:complexType)) - (soap-namespace-put (soap-parse-complex-type node) ns)) + (dolist (node (soap-xml-get-children1 node 'wsdl:import)) + (let ((location (xml-get-attribute-or-nil node 'location))) + (when location + (soap-load-wsdl location wsdl)))))) - (dolist (node (soap-xml-get-children1 node 'xsd:element)) - (soap-namespace-put (soap-parse-schema-element node) ns)) - - ns))) - -(defun soap-parse-simple-type (node) - "Parse NODE and construct a simple type from it." - (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:simpleType) - nil - "soap-parse-complex-type: expecting xsd:simpleType node, got %s" - (soap-l2wk (xml-node-name node))) - (let ((name (xml-get-attribute-or-nil node 'name)) - type - enumeration - (restriction (car-safe - (soap-xml-get-children1 node 'xsd:restriction)))) - (unless restriction - (error "simpleType %s has no base type" name)) - - (setq type (xml-get-attribute-or-nil restriction 'base)) - (dolist (e (soap-xml-get-children1 restriction 'xsd:enumeration)) - (push (xml-get-attribute e 'value) enumeration)) - - (make-soap-simple-type :name name :kind type :enumeration enumeration))) - -(defun soap-parse-schema-element (node) - "Parse NODE and construct a schema element from it." - (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:element) - nil - "soap-parse-schema-element: expecting xsd:element node, got %s" - (soap-l2wk (xml-node-name node))) - (let ((name (xml-get-attribute-or-nil node 'name)) - type) - ;; A schema element that contains an inline complex type -- - ;; construct the actual complex type for it. - (let ((type-node (soap-xml-get-children1 node 'xsd:complexType))) - (when (> (length type-node) 0) - (assert (= (length type-node) 1)) ; only one complex type - ; definition per element - (setq type (soap-parse-complex-type (car type-node))))) - (setf (soap-element-name type) name) - type)) - -(defun soap-parse-complex-type (node) - "Parse NODE and construct a complex type from it." - (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:complexType) - nil - "soap-parse-complex-type: expecting xsd:complexType node, got %s" - (soap-l2wk (xml-node-name node))) - (let ((name (xml-get-attribute-or-nil node 'name)) - ;; Use a dummy type for the complex type, it will be replaced - ;; with the real type below, except when the complex type node - ;; is empty... - (type (make-soap-sequence-type :elements nil))) - (dolist (c (xml-node-children node)) - (when (consp c) ; skip string nodes, which are whitespace - (let ((node-name (soap-l2wk (xml-node-name c)))) - (cond - ;; The difference between xsd:all and xsd:sequence is that fields - ;; in xsd:all are not ordered and they can occur only once. We - ;; don't care about that difference in soap-client.el - ((or (eq node-name 'xsd:sequence) - (eq node-name 'xsd:all)) - (setq type (soap-parse-complex-type-sequence c))) - ((eq node-name 'xsd:complexContent) - (setq type (soap-parse-complex-type-complex-content c))) - ((eq node-name 'xsd:attribute) - ;; The name of this node comes from an attribute tag - (let ((n (xml-get-attribute-or-nil c 'name))) - (setq name n))) - (t - (error "Unknown node type %s" node-name)))))) - (setf (soap-element-name type) name) - type)) - -(defun soap-parse-sequence (node) - "Parse NODE and a list of sequence elements that it defines. -NODE is assumed to be an xsd:sequence node. In that case, each -of its children is assumed to be a sequence element. Each -sequence element is parsed constructing the corresponding type. -A list of these types is returned." - (assert (let ((n (soap-l2wk (xml-node-name node)))) - (memq n '(xsd:sequence xsd:all))) - nil - "soap-parse-sequence: expecting xsd:sequence or xsd:all node, got %s" - (soap-l2wk (xml-node-name node))) - (let (elements) - (dolist (e (soap-xml-get-children1 node 'xsd:element)) - (let ((name (xml-get-attribute-or-nil e 'name)) - (type (xml-get-attribute-or-nil e 'type)) - (nillable? (or (equal (xml-get-attribute-or-nil e 'nillable) "true") - (let ((e (xml-get-attribute-or-nil e 'minOccurs))) - (and e (equal e "0"))))) - (multiple? (let ((e (xml-get-attribute-or-nil e 'maxOccurs))) - (and e (not (equal e "1")))))) - (if type - (setq type (soap-l2fq type 'tns)) - - ;; The node does not have a type, maybe it has a complexType - ;; defined inline... - (let ((type-node (soap-xml-get-children1 e 'xsd:complexType))) - (when (> (length type-node) 0) - (assert (= (length type-node) 1) - nil - "only one complex type definition per element supported") - (setq type (soap-parse-complex-type (car type-node)))))) - - (push (make-soap-sequence-element - :name (intern name) :type type :nillable? nillable? - :multiple? multiple?) - elements))) - (nreverse elements))) - -(defun soap-parse-complex-type-sequence (node) - "Parse NODE as a sequence type." - (let ((elements (soap-parse-sequence node))) - (make-soap-sequence-type :elements elements))) - -(defun soap-parse-complex-type-complex-content (node) - "Parse NODE as a xsd:complexContent node. -A sequence or an array type is returned depending on the actual -contents." - (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:complexContent) - nil - "soap-parse-complex-type-complex-content: expecting xsd:complexContent node, got %s" - (soap-l2wk (xml-node-name node))) - (let (array? parent elements) - (let ((extension (car-safe (soap-xml-get-children1 node 'xsd:extension))) - (restriction (car-safe - (soap-xml-get-children1 node 'xsd:restriction)))) - ;; a complex content node is either an extension or a restriction - (cond (extension - (setq parent (xml-get-attribute-or-nil extension 'base)) - (setq elements (soap-parse-sequence - (car (soap-xml-get-children1 - extension 'xsd:sequence))))) - (restriction - (let ((base (xml-get-attribute-or-nil restriction 'base))) - (assert (equal base (soap-wk2l "soapenc:Array")) - nil - "restrictions supported only for soapenc:Array types, this is a %s" - base)) - (setq array? t) - (let ((attribute (car (soap-xml-get-children1 - restriction 'xsd:attribute)))) - (let ((array-type (soap-xml-get-attribute-or-nil1 - attribute 'wsdl:arrayType))) - (when (string-match "^\\(.*\\)\\[\\]$" array-type) - (setq parent (match-string 1 array-type)))))) - - (t - (error "Unknown complex type")))) - - (if parent - (setq parent (soap-l2fq parent 'tns))) +(defun soap-parse-wsdl-phase-parse-schema (node wsdl) + "Load types found in NODE into WSDL." + (soap-with-local-xmlns node + ;; Find all the 'xsd:schema nodes which are children of wsdl:types nodes and + ;; build our type-library. + (let ((types (car (soap-xml-get-children1 node 'wsdl:types)))) + (dolist (node (xml-node-children types)) + ;; We cannot use (xml-get-children node (soap-wk2l 'xsd:schema)) because + ;; each node can install its own alias type so the schema nodes might + ;; have a different prefix. + (when (consp node) + (soap-with-local-xmlns + node + (when (eq (soap-l2wk (xml-node-name node)) 'xsd:schema) + (soap-wsdl-add-namespace (soap-parse-schema node wsdl) + wsdl)))))))) + +(defun soap-parse-wsdl-phase-fetch-schema (node wsdl) + "Fetch and load schema imports defined by NODE into WSDL." + (soap-with-local-xmlns node + (while (soap-wsdl-xmlschema-imports wsdl) + (let* ((import (pop (soap-wsdl-xmlschema-imports wsdl))) + (xml (soap-fetch-xml import wsdl))) + (soap-wsdl-add-namespace (soap-parse-schema xml wsdl) wsdl))))) - (if array? - (make-soap-array-type :element-type parent) - (make-soap-sequence-type :parent parent :elements elements)))) +(defun soap-parse-wsdl-phase-finish-parsing (node wsdl) + "Finish parsing NODE into WSDL." + (soap-with-local-xmlns node + (let ((ns (make-soap-namespace :name (soap-get-target-namespace node)))) + (dolist (node (soap-xml-get-children1 node 'wsdl:message)) + (soap-namespace-put (soap-parse-message node) ns)) + + (dolist (node (soap-xml-get-children1 node 'wsdl:portType)) + (let ((port-type (soap-parse-port-type node))) + (soap-namespace-put port-type ns) + (soap-wsdl-add-namespace + (soap-port-type-operations port-type) wsdl))) + + (dolist (node (soap-xml-get-children1 node 'wsdl:binding)) + (soap-namespace-put (soap-parse-binding node) ns)) + + (dolist (node (soap-xml-get-children1 node 'wsdl:service)) + (dolist (node (soap-xml-get-children1 node 'wsdl:port)) + (let ((name (xml-get-attribute node 'name)) + (binding (xml-get-attribute node 'binding)) + (url (let ((n (car (soap-xml-get-children1 + node 'wsdlsoap:address)))) + (xml-get-attribute n 'location)))) + (let ((port (make-soap-port + :name name :binding (soap-l2fq binding 'tns) + :service-url url))) + (soap-namespace-put port ns) + (push port (soap-wsdl-ports wsdl)))))) + + (soap-wsdl-add-namespace ns wsdl)))) + +(defun soap-parse-wsdl (node wsdl) + "Construct from NODE a WSDL structure, which is an XML document." + ;; Break this into phases to allow for asynchronous parsing. + (soap-parse-wsdl-phase-validate-node node) + ;; Makes synchronous calls. + (soap-parse-wsdl-phase-fetch-imports node wsdl) + (soap-parse-wsdl-phase-parse-schema node wsdl) + ;; Makes synchronous calls. + (soap-parse-wsdl-phase-fetch-schema node wsdl) + (soap-parse-wsdl-phase-finish-parsing node wsdl) + wsdl) (defun soap-parse-message (node) "Parse NODE as a wsdl:message and return the corresponding type." (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:message) nil - "soap-parse-message: expecting wsdl:message node, got %s" + "expecting wsdl:message node, got %s" (soap-l2wk (xml-node-name node))) (let ((name (xml-get-attribute-or-nil node 'name)) parts) @@ -1061,97 +2485,111 @@ contents." (when type (setq type (soap-l2fq type 'tns))) - (when element - (setq element (soap-l2fq element 'tns))) + (if element + (setq element (soap-l2fq element 'tns)) + ;; else + (setq element (make-soap-xs-element + :name name + :namespace-tag soap-target-xmlns + :type^ type))) - (push (cons name (or type element)) parts))) + (push (cons name element) parts))) (make-soap-message :name name :parts (nreverse parts)))) (defun soap-parse-port-type (node) "Parse NODE as a wsdl:portType and return the corresponding port." (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:portType) nil - "soap-parse-port-type: expecting wsdl:portType node got %s" + "expecting wsdl:portType node got %s" (soap-l2wk (xml-node-name node))) - (let ((ns (make-soap-namespace - :name (concat "urn:" (xml-get-attribute node 'name))))) + (let* ((soap-target-xmlns (concat "urn:" (xml-get-attribute node 'name))) + (ns (make-soap-namespace :name soap-target-xmlns))) (dolist (node (soap-xml-get-children1 node 'wsdl:operation)) (let ((o (soap-parse-operation node))) (let ((other-operation (soap-namespace-get - (soap-element-name o) ns 'soap-operation-p))) + (soap-element-name o) ns 'soap-operation-p))) (if other-operation ;; Unfortunately, the Confluence WSDL defines two operations ;; named "search" which differ only in parameter names... (soap-warning "Discarding duplicate operation: %s" - (soap-element-name o)) + (soap-element-name o)) - (progn - (soap-namespace-put o ns) + (progn + (soap-namespace-put o ns) - ;; link all messages from this namespace, as this namespace - ;; will be used for decoding the response. - (destructuring-bind (name . message) (soap-operation-input o) - (soap-namespace-put-link name message ns)) + ;; link all messages from this namespace, as this namespace + ;; will be used for decoding the response. + (destructuring-bind (name . message) (soap-operation-input o) + (soap-namespace-put-link name message ns)) - (destructuring-bind (name . message) (soap-operation-output o) - (soap-namespace-put-link name message ns)) + (destructuring-bind (name . message) (soap-operation-output o) + (soap-namespace-put-link name message ns)) - (dolist (fault (soap-operation-faults o)) - (destructuring-bind (name . message) fault - (soap-namespace-put-link name message ns 'replace))) + (dolist (fault (soap-operation-faults o)) + (destructuring-bind (name . message) fault + (soap-namespace-put-link name message ns))) - ))))) + ))))) (make-soap-port-type :name (xml-get-attribute node 'name) - :operations ns))) + :operations ns))) (defun soap-parse-operation (node) "Parse NODE as a wsdl:operation and return the corresponding type." (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:operation) nil - "soap-parse-operation: expecting wsdl:operation node, got %s" + "expecting wsdl:operation node, got %s" (soap-l2wk (xml-node-name node))) (let ((name (xml-get-attribute node 'name)) (parameter-order (split-string - (xml-get-attribute node 'parameterOrder))) - input output faults) + (xml-get-attribute node 'parameterOrder))) + input output faults input-action output-action) (dolist (n (xml-node-children node)) (when (consp n) ; skip string nodes which are whitespace (let ((node-name (soap-l2wk (xml-node-name n)))) (cond - ((eq node-name 'wsdl:input) - (let ((message (xml-get-attribute n 'message)) - (name (xml-get-attribute n 'name))) - (setq input (cons name (soap-l2fq message 'tns))))) - ((eq node-name 'wsdl:output) - (let ((message (xml-get-attribute n 'message)) - (name (xml-get-attribute n 'name))) - (setq output (cons name (soap-l2fq message 'tns))))) - ((eq node-name 'wsdl:fault) - (let ((message (xml-get-attribute n 'message)) - (name (xml-get-attribute n 'name))) - (push (cons name (soap-l2fq message 'tns)) faults))))))) + ((eq node-name 'wsdl:input) + (let ((message (xml-get-attribute n 'message)) + (name (xml-get-attribute n 'name)) + (action (soap-xml-get-attribute-or-nil1 n 'wsaw:Action))) + (setq input (cons name (soap-l2fq message 'tns))) + (setq input-action action))) + ((eq node-name 'wsdl:output) + (let ((message (xml-get-attribute n 'message)) + (name (xml-get-attribute n 'name)) + (action (soap-xml-get-attribute-or-nil1 n 'wsaw:Action))) + (setq output (cons name (soap-l2fq message 'tns))) + (setq output-action action))) + ((eq node-name 'wsdl:fault) + (let ((message (xml-get-attribute n 'message)) + (name (xml-get-attribute n 'name))) + (push (cons name (soap-l2fq message 'tns)) faults))))))) (make-soap-operation :name name + :namespace-tag soap-target-xmlns :parameter-order parameter-order :input input :output output - :faults (nreverse faults)))) + :faults (nreverse faults) + :input-action input-action + :output-action output-action))) (defun soap-parse-binding (node) "Parse NODE as a wsdl:binding and return the corresponding type." (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:binding) nil - "soap-parse-binding: expecting wsdl:binding node, got %s" + "expecting wsdl:binding node, got %s" (soap-l2wk (xml-node-name node))) (let ((name (xml-get-attribute node 'name)) (type (xml-get-attribute node 'type))) (let ((binding (make-soap-binding :name name - :port-type (soap-l2fq type 'tns)))) + :port-type (soap-l2fq type 'tns)))) (dolist (wo (soap-xml-get-children1 node 'wsdl:operation)) (let ((name (xml-get-attribute wo 'name)) soap-action + soap-headers + soap-body use) (dolist (so (soap-xml-get-children1 wo 'wsdlsoap:operation)) (setq soap-action (xml-get-attribute-or-nil so 'soapAction))) @@ -1162,9 +2600,24 @@ contents." ;; "use"-s for each of them... (dolist (i (soap-xml-get-children1 wo 'wsdl:input)) - (dolist (b (soap-xml-get-children1 i 'wsdlsoap:body)) - (setq use (or use - (xml-get-attribute-or-nil b 'use))))) + + ;; There can be multiple headers ... + (dolist (h (soap-xml-get-children1 i 'wsdlsoap:header)) + (let ((message (soap-l2fq (xml-get-attribute-or-nil h 'message))) + (part (xml-get-attribute-or-nil h 'part)) + (use (xml-get-attribute-or-nil h 'use))) + (when (and message part) + (push (list message part use) soap-headers)))) + + ;; ... but only one body + (let ((body (car (soap-xml-get-children1 i 'wsdlsoap:body)))) + (setq soap-body (xml-get-attribute-or-nil body 'parts)) + (when soap-body + (setq soap-body + (mapcar #'intern (split-string soap-body + nil + 'omit-nulls)))) + (setq use (xml-get-attribute-or-nil body 'use)))) (unless use (dolist (i (soap-xml-get-children1 wo 'wsdl:output)) @@ -1172,9 +2625,12 @@ contents." (setq use (or use (xml-get-attribute-or-nil b 'use)))))) - (puthash name (make-soap-bound-operation :operation name - :soap-action soap-action - :use (and use (intern use))) + (puthash name (make-soap-bound-operation + :operation name + :soap-action soap-action + :soap-headers (nreverse soap-headers) + :soap-body soap-body + :use (and use (intern use))) (soap-binding-operations binding)))) binding))) @@ -1190,10 +2646,6 @@ SOAP response.") This is a dynamically bound variable used during decoding the SOAP response.") -(defvar soap-current-wsdl nil - "The current WSDL document used when decoding the SOAP response. -This is a dynamically bound variable.") - (defun soap-decode-type (type node) "Use TYPE (an xsd type) to decode the contents of NODE. @@ -1211,7 +2663,8 @@ decode function to perform the actual decoding." (when decoded (throw 'done decoded))) - (string-match "^#\\(.*\\)$" href) ; TODO: check that it matched + (unless (string-match "^#\\(.*\\)$" href) + (error "Invalid multiRef: %s" href)) (let ((id (match-string 1 href))) (dolist (mr soap-multi-refs) @@ -1226,38 +2679,53 @@ decode function to perform the actual decoding." (soap-with-local-xmlns node (if (equal (soap-xml-get-attribute-or-nil1 node 'xsi:nil) "true") nil - (let ((decoder (get (aref type 0) 'soap-decoder))) - (assert decoder nil "no soap-decoder for %s type" - (aref type 0)) - (funcall decoder type node)))))))) + ;; Handle union types. + (cond ((listp type) + (catch 'done + (dolist (union-member type) + (let* ((decoder (get (aref union-member 0) + 'soap-decoder)) + (result (ignore-errors + (funcall decoder + union-member node)))) + (when result (throw 'done result)))))) + (t + (let ((decoder (get (aref type 0) 'soap-decoder))) + (assert decoder nil + "no soap-decoder for %s type" (aref type 0)) + (funcall decoder type node)))))))))) (defun soap-decode-any-type (node) "Decode NODE using type information inside it." ;; If the NODE has type information, we use that... (let ((type (soap-xml-get-attribute-or-nil1 node 'xsi:type))) + (when type + (setq type (soap-l2fq type))) (if type - (let ((wtype (soap-wsdl-get type soap-current-wsdl 'soap-type-p))) + (let ((wtype (soap-wsdl-get type soap-current-wsdl 'soap-xs-type-p))) (if wtype (soap-decode-type wtype node) - ;; The node has type info encoded in it, but we don't know how - ;; to decode it... - (error "Soap-decode-any-type: node has unknown type: %s" type))) - - ;; No type info in the node... - - (let ((contents (xml-node-children node))) - (if (and (= (length contents) 1) (stringp (car contents))) - ;; contents is just a string - (car contents) - - ;; we assume the NODE is a sequence with every element a - ;; structure name - (let (result) - (dolist (element contents) - (let ((key (xml-node-name element)) - (value (soap-decode-any-type element))) - (push (cons key value) result))) - (nreverse result))))))) + ;; The node has type info encoded in it, but we don't know how + ;; to decode it... + (error "Node has unknown type: %s" type))) + + ;; No type info in the node... + + (let ((contents (xml-node-children node))) + (if (and (= (length contents) 1) (stringp (car contents))) + ;; contents is just a string + (car contents) + + ;; we assume the NODE is a sequence with every element a + ;; structure name + (let (result) + (dolist (element contents) + ;; skip any string contents, assume they are whitespace + (unless (stringp element) + (let ((key (xml-node-name element)) + (value (soap-decode-any-type element))) + (push (cons key value) result)))) + (nreverse result))))))) (defun soap-decode-array (node) "Decode NODE as an Array using type information inside it." @@ -1266,90 +2734,23 @@ decode function to perform the actual decoding." (contents (xml-node-children node)) result) (when type - ;; Type is in the format "someType[NUM]" where NUM is the number of - ;; elements in the array. We discard the [NUM] part. - (setq type (replace-regexp-in-string "\\[[0-9]+\\]\\'" "" type)) - (setq wtype (soap-wsdl-get type soap-current-wsdl 'soap-type-p)) - (unless wtype - ;; The node has type info encoded in it, but we don't know how to - ;; decode it... - (error "Soap-decode-array: node has unknown type: %s" type))) + ;; Type is in the format "someType[NUM]" where NUM is the number of + ;; elements in the array. We discard the [NUM] part. + (setq type (replace-regexp-in-string "\\[[0-9]+\\]\\'" "" type)) + (setq wtype (soap-wsdl-get (soap-l2fq type) + soap-current-wsdl 'soap-xs-type-p)) + (unless wtype + ;; The node has type info encoded in it, but we don't know how to + ;; decode it... + (error "Soap-decode-array: node has unknown type: %s" type))) (dolist (e contents) (when (consp e) (push (if wtype (soap-decode-type wtype e) - (soap-decode-any-type e)) + (soap-decode-any-type e)) result))) (nreverse result))) -(defun soap-decode-basic-type (type node) - "Use TYPE to decode the contents of NODE. -TYPE is a `soap-basic-type' struct, and NODE is an XML document. -A LISP value is returned based on the contents of NODE and the -type-info stored in TYPE." - (let ((contents (xml-node-children node)) - (type-kind (soap-basic-type-kind type))) - - (if (null contents) - nil - (ecase type-kind - ((string anyURI) (car contents)) - (dateTime (car contents)) ; TODO: convert to a date time - ((long int integer unsignedInt byte float double) (string-to-number (car contents))) - (boolean (string= (downcase (car contents)) "true")) - (base64Binary (base64-decode-string (car contents))) - (anyType (soap-decode-any-type node)) - (Array (soap-decode-array node)))))) - -(defun soap-decode-sequence-type (type node) - "Use TYPE to decode the contents of NODE. -TYPE is assumed to be a sequence type and an ALIST with the -contents of the NODE is returned." - (let ((result nil) - (parent (soap-sequence-type-parent type))) - (when parent - (setq result (nreverse (soap-decode-type parent node)))) - (dolist (element (soap-sequence-type-elements type)) - (let ((instance-count 0) - (e-name (soap-sequence-element-name element)) - (e-type (soap-sequence-element-type element))) - (dolist (node (xml-get-children node e-name)) - (incf instance-count) - (push (cons e-name (soap-decode-type e-type node)) result)) - ;; Do some sanity checking - (cond ((and (= instance-count 0) - (not (soap-sequence-element-nillable? element))) - (soap-warning "While decoding %s: missing non-nillable slot %s" - (soap-element-name type) e-name)) - ((and (> instance-count 1) - (not (soap-sequence-element-multiple? element))) - (soap-warning "While decoding %s: multiple slots named %s" - (soap-element-name type) e-name))))) - (nreverse result))) - -(defun soap-decode-array-type (type node) - "Use TYPE to decode the contents of NODE. -TYPE is assumed to be an array type. Arrays are decoded as lists. -This is because it is easier to work with list results in LISP." - (let ((result nil) - (element-type (soap-array-type-element-type type))) - (dolist (node (xml-node-children node)) - (when (consp node) - (push (soap-decode-type element-type node) result))) - (nreverse result))) - -(progn - (put (aref (make-soap-basic-type) 0) - 'soap-decoder 'soap-decode-basic-type) - ;; just use the basic type decoder for the simple type -- we accept any - ;; value and don't do any validation on it. - (put (aref (make-soap-simple-type) 0) - 'soap-decoder 'soap-decode-basic-type) - (put (aref (make-soap-sequence-type) 0) - 'soap-decoder 'soap-decode-sequence-type) - (put (aref (make-soap-array-type) 0) - 'soap-decoder 'soap-decode-array-type)) - ;;;; Soap Envelope parsing (define-error 'soap-error "SOAP error") @@ -1361,40 +2762,44 @@ WSDL is used to decode the NODE" (soap-with-local-xmlns node (assert (eq (soap-l2wk (xml-node-name node)) 'soap:Envelope) nil - "soap-parse-envelope: expecting soap:Envelope node, got %s" + "expecting soap:Envelope node, got %s" (soap-l2wk (xml-node-name node))) - (let ((body (car (soap-xml-get-children1 node 'soap:Body)))) + (let ((headers (soap-xml-get-children1 node 'soap:Header)) + (body (car (soap-xml-get-children1 node 'soap:Body)))) (let ((fault (car (soap-xml-get-children1 body 'soap:Fault)))) (when fault (let ((fault-code (let ((n (car (xml-get-children - fault 'faultcode)))) + fault 'faultcode)))) (car-safe (xml-node-children n)))) (fault-string (let ((n (car (xml-get-children fault 'faultstring)))) (car-safe (xml-node-children n)))) (detail (xml-get-children fault 'detail))) - (while t - (signal 'soap-error (list fault-code fault-string detail)))))) + (while t + (signal 'soap-error (list fault-code fault-string detail)))))) ;; First (non string) element of the body is the root node of he ;; response (let ((response (if (eq (soap-bound-operation-use operation) 'literal) ;; For 'literal uses, the response is the actual body body - ;; ...otherwise the first non string element - ;; of the body is the response - (catch 'found - (dolist (n (xml-node-children body)) - (when (consp n) - (throw 'found n))))))) - (soap-parse-response response operation wsdl body))))) - -(defun soap-parse-response (response-node operation wsdl soap-body) + ;; ...otherwise the first non string element + ;; of the body is the response + (catch 'found + (dolist (n (xml-node-children body)) + (when (consp n) + (throw 'found n))))))) + (soap-parse-response response operation wsdl headers body))))) + +(defun soap-parse-response (response-node operation wsdl soap-headers soap-body) "Parse RESPONSE-NODE and return the result as a LISP value. OPERATION is the WSDL operation for which we expect the response, WSDL is used to decode the NODE. +SOAP-HEADERS is a list of the headers of the SOAP envelope or nil +if there are no headers. + SOAP-BODY is the body of the SOAP envelope (of which RESPONSE-NODE is a sub-node). It is used in case RESPONSE-NODE reference multiRef parts which are external to RESPONSE-NODE." @@ -1408,7 +2813,7 @@ reference multiRef parts which are external to RESPONSE-NODE." (when (eq use 'encoded) (let* ((received-message-name (soap-l2fq (xml-node-name response-node))) (received-message (soap-wsdl-get - received-message-name wsdl 'soap-message-p))) + received-message-name wsdl 'soap-message-p))) (unless (eq received-message message) (error "Unexpected message: got %s, expecting %s" received-message-name @@ -1425,42 +2830,52 @@ reference multiRef parts which are external to RESPONSE-NODE." (setq node (cond - ((eq use 'encoded) - (car (xml-get-children response-node tag))) - - ((eq use 'literal) - (catch 'found - (let* ((ns-aliases (soap-wsdl-alias-table wsdl)) - (ns-name (cdr (assoc - (soap-element-namespace-tag type) - ns-aliases))) - (fqname (cons ns-name (soap-element-name type)))) - (dolist (c (xml-node-children response-node)) - (when (consp c) - (soap-with-local-xmlns c - (when (equal (soap-l2fq (xml-node-name c)) - fqname) - (throw 'found c)))))))))) + ((eq use 'encoded) + (car (xml-get-children response-node tag))) + + ((eq use 'literal) + (catch 'found + (let* ((ns-aliases (soap-wsdl-alias-table wsdl)) + (ns-name (cdr (assoc + (soap-element-namespace-tag type) + ns-aliases))) + (fqname (cons ns-name (soap-element-name type)))) + (dolist (c (append (mapcar (lambda (header) + (car (xml-node-children + header))) + soap-headers) + (xml-node-children response-node))) + (when (consp c) + (soap-with-local-xmlns c + (when (equal (soap-l2fq (xml-node-name c)) + fqname) + (throw 'found c)))))))))) (unless node (error "Soap-parse-response(%s): cannot find message part %s" (soap-element-name op) tag)) - (push (soap-decode-type type node) decoded-parts))) + (let ((decoded-value (soap-decode-type type node))) + (when decoded-value + (push decoded-value decoded-parts))))) decoded-parts)))) ;;;; SOAP type encoding -(defvar soap-encoded-namespaces nil - "A list of namespace tags used during encoding a message. -This list is populated by `soap-encode-value' and used by -`soap-create-envelope' to add aliases for these namespace to the -XML request. +(defun soap-encode-attributes (value type) + "Encode XML attributes for VALUE according to TYPE. +This is a generic function which determines the attribute encoder +for the type and calls that specialized function to do the work. -This variable is dynamically bound in `soap-create-envelope'.") +Attributes are inserted in the current buffer at the current +position." + (let ((attribute-encoder (get (aref type 0) 'soap-attribute-encoder))) + (assert attribute-encoder nil + "no soap-attribute-encoder for %s type" (aref type 0)) + (funcall attribute-encoder value type))) -(defun soap-encode-value (xml-tag value type) - "Encode inside an XML-TAG the VALUE using TYPE. +(defun soap-encode-value (value type) + "Encode the VALUE using TYPE. The resulting XML data is inserted in the current buffer at (point)/ @@ -1470,190 +2885,24 @@ encoder function based on TYPE and calls that encoder to do the work." (let ((encoder (get (aref type 0) 'soap-encoder))) (assert encoder nil "no soap-encoder for %s type" (aref type 0)) - ;; XML-TAG can be a string or a symbol, but we pass only string's to the - ;; encoders - (when (symbolp xml-tag) - (setq xml-tag (symbol-name xml-tag))) - (funcall encoder xml-tag value type)) - (add-to-list 'soap-encoded-namespaces (soap-element-namespace-tag type))) - -(defun soap-encode-basic-type (xml-tag value type) - "Encode inside XML-TAG the LISP VALUE according to TYPE. -Do not call this function directly, use `soap-encode-value' -instead." - (let ((xsi-type (soap-element-fq-name type)) - (basic-type (soap-basic-type-kind type))) - - ;; try to classify the type based on the value type and use that type when - ;; encoding - (when (eq basic-type 'anyType) - (cond ((stringp value) - (setq xsi-type "xsd:string" basic-type 'string)) - ((integerp value) - (setq xsi-type "xsd:int" basic-type 'int)) - ((memq value '(t nil)) - (setq xsi-type "xsd:boolean" basic-type 'boolean)) - (t - (error - "Soap-encode-basic-type(%s, %s, %s): cannot classify anyType value" - xml-tag value xsi-type)))) + (funcall encoder value type)) + (when (soap-element-namespace-tag type) + (add-to-list 'soap-encoded-namespaces (soap-element-namespace-tag type)))) - (insert "<" xml-tag " xsi:type=\"" xsi-type "\"") - - ;; We have some ambiguity here, as a nil value represents "false" when the - ;; type is boolean, we will never have a "nil" boolean type... - - (if (or value (eq basic-type 'boolean)) - (progn - (insert ">") - (case basic-type - ((string anyURI) - (unless (stringp value) - (error "Soap-encode-basic-type(%s, %s, %s): not a string value" - xml-tag value xsi-type)) - (insert (url-insert-entities-in-string value))) - - (dateTime - (cond ((and (consp value) ; is there a time-value-p ? - (>= (length value) 2) - (numberp (nth 0 value)) - (numberp (nth 1 value))) - ;; Value is a (current-time) style value, convert - ;; to a string - (insert (format-time-string "%Y-%m-%dT%H:%M:%S" value))) - ((stringp value) - (insert (url-insert-entities-in-string value))) - (t - (error - "Soap-encode-basic-type(%s, %s, %s): not a dateTime value" - xml-tag value xsi-type)))) - - (boolean - (unless (memq value '(t nil)) - (error "Soap-encode-basic-type(%s, %s, %s): not a boolean value" - xml-tag value xsi-type)) - (insert (if value "true" "false"))) - - ((long int integer byte unsignedInt) - (unless (integerp value) - (error "Soap-encode-basic-type(%s, %s, %s): not an integer value" - xml-tag value xsi-type)) - (when (and (eq basic-type 'unsignedInt) (< value 0)) - (error "Soap-encode-basic-type(%s, %s, %s): not a positive integer" - xml-tag value xsi-type)) - (insert (number-to-string value))) - - ((float double) - (unless (numberp value) - (error "Soap-encode-basic-type(%s, %s, %s): not a number" - xml-tag value xsi-type)) - (insert (number-to-string value))) - - (base64Binary - (unless (stringp value) - (error "Soap-encode-basic-type(%s, %s, %s): not a string value" - xml-tag value xsi-type)) - (insert (base64-encode-string value))) - - (otherwise - (error - "Soap-encode-basic-type(%s, %s, %s): don't know how to encode" - xml-tag value xsi-type)))) - - (insert " xsi:nil=\"true\">")) - (insert "</" xml-tag ">\n"))) - -(defun soap-encode-simple-type (xml-tag value type) - "Encode inside XML-TAG the LISP VALUE according to TYPE." - - ;; Validate VALUE against the simple type's enumeration, than just encode it - ;; using `soap-encode-basic-type' - - (let ((enumeration (soap-simple-type-enumeration type))) - (unless (and (> (length enumeration) 1) - (member value enumeration)) - (error "soap-encode-simple-type(%s, %s, %s): bad value, should be one of %s" - xml-tag value (soap-element-fq-name type) enumeration))) - - (soap-encode-basic-type xml-tag value type)) - -(defun soap-encode-sequence-type (xml-tag value type) - "Encode inside XML-TAG the LISP VALUE according to TYPE. -Do not call this function directly, use `soap-encode-value' -instead." - (let ((xsi-type (soap-element-fq-name type))) - (insert "<" xml-tag " xsi:type=\"" xsi-type "\"") - (if value - (progn - (insert ">\n") - (let ((parents (list type)) - (parent (soap-sequence-type-parent type))) - - (while parent - (push parent parents) - (setq parent (soap-sequence-type-parent parent))) - - (dolist (type parents) - (dolist (element (soap-sequence-type-elements type)) - (let ((instance-count 0) - (e-name (soap-sequence-element-name element)) - (e-type (soap-sequence-element-type element))) - (dolist (v value) - (when (equal (car v) e-name) - (incf instance-count) - (soap-encode-value e-name (cdr v) e-type))) - - ;; Do some sanity checking - (cond ((and (= instance-count 0) - (not (soap-sequence-element-nillable? element))) - (soap-warning - "While encoding %s: missing non-nillable slot %s" - (soap-element-name type) e-name)) - ((and (> instance-count 1) - (not (soap-sequence-element-multiple? element))) - (soap-warning - "While encoding %s: multiple slots named %s" - (soap-element-name type) e-name)))))))) - (insert " xsi:nil=\"true\">")) - (insert "</" xml-tag ">\n"))) - -(defun soap-encode-array-type (xml-tag value type) - "Encode inside XML-TAG the LISP VALUE according to TYPE. -Do not call this function directly, use `soap-encode-value' -instead." - (unless (vectorp value) - (error "Soap-encode: %s(%s) expects a vector, got: %s" - xml-tag (soap-element-fq-name type) value)) - (let* ((element-type (soap-array-type-element-type type)) - (array-type (concat (soap-element-fq-name element-type) - "[" (format "%s" (length value)) "]"))) - (insert "<" xml-tag - " soapenc:arrayType=\"" array-type "\" " - " xsi:type=\"soapenc:Array\">\n") - (loop for i below (length value) - do (soap-encode-value xml-tag (aref value i) element-type)) - (insert "</" xml-tag ">\n"))) - -(progn - (put (aref (make-soap-basic-type) 0) - 'soap-encoder 'soap-encode-basic-type) - (put (aref (make-soap-simple-type) 0) - 'soap-encoder 'soap-encode-simple-type) - (put (aref (make-soap-sequence-type) 0) - 'soap-encoder 'soap-encode-sequence-type) - (put (aref (make-soap-array-type) 0) - 'soap-encoder 'soap-encode-array-type)) - -(defun soap-encode-body (operation parameters wsdl) +(defun soap-encode-body (operation parameters &optional service-url) "Create the body of a SOAP request for OPERATION in the current buffer. PARAMETERS is a list of parameters supplied to the OPERATION. The OPERATION and PARAMETERS are encoded according to the WSDL -document." +document. SERVICE-URL should be provided when WS-Addressing is +being used." (let* ((op (soap-bound-operation-operation operation)) (use (soap-bound-operation-use operation)) (message (cdr (soap-operation-input op))) - (parameter-order (soap-operation-parameter-order op))) + (parameter-order (soap-operation-parameter-order op)) + (param-table (loop for formal in parameter-order + for value in parameters + collect (cons formal value)))) (unless (= (length parameter-order) (length parameters)) (error "Wrong number of parameters for %s: expected %d, got %s" @@ -1661,62 +2910,73 @@ document." (length parameter-order) (length parameters))) + (let ((headers (soap-bound-operation-soap-headers operation)) + (input-action (soap-operation-input-action op))) + (when headers + (insert "<soap:Header>\n") + (when input-action + (add-to-list 'soap-encoded-namespaces "wsa") + (insert "<wsa:Action>" input-action "</wsa:Action>\n") + (insert "<wsa:To>" service-url "</wsa:To>\n")) + (dolist (h headers) + (let* ((message (nth 0 h)) + (part (assq (nth 1 h) (soap-message-parts message))) + (value (cdr (assoc (car part) (car parameters)))) + (use (nth 2 h)) + (element (cdr part))) + (when (eq use 'encoded) + (when (soap-element-namespace-tag element) + (add-to-list 'soap-encoded-namespaces + (soap-element-namespace-tag element))) + (insert "<" (soap-element-fq-name element) ">\n")) + (soap-encode-value value element) + (when (eq use 'encoded) + (insert "</" (soap-element-fq-name element) ">\n")))) + (insert "</soap:Header>\n"))) + (insert "<soap:Body>\n") (when (eq use 'encoded) - (add-to-list 'soap-encoded-namespaces (soap-element-namespace-tag op)) + (when (soap-element-namespace-tag op) + (add-to-list 'soap-encoded-namespaces (soap-element-namespace-tag op))) (insert "<" (soap-element-fq-name op) ">\n")) - (let ((param-table (loop for formal in parameter-order - for value in parameters - collect (cons formal value)))) - (dolist (part (soap-message-parts message)) - (let* ((param-name (car part)) - (type (cdr part)) - (tag-name (if (eq use 'encoded) - param-name - (soap-element-name type))) - (value (cdr (assoc param-name param-table))) - (start-pos (point))) - (soap-encode-value tag-name value type) - (when (eq use 'literal) - ;; hack: add the xmlns attribute to the tag, the only way - ;; ASP.NET web services recognize the namespace of the - ;; element itself... - (save-excursion - (goto-char start-pos) - (when (re-search-forward " ") - (let* ((ns (soap-element-namespace-tag type)) - (namespace (cdr (assoc ns - (soap-wsdl-alias-table wsdl))))) - (when namespace - (insert "xmlns=\"" namespace "\" "))))))))) + (dolist (part (soap-message-parts message)) + (let* ((param-name (car part)) + (element (cdr part)) + (value (cdr (assoc param-name param-table)))) + (when (or (null (soap-bound-operation-soap-body operation)) + (member param-name + (soap-bound-operation-soap-body operation))) + (soap-encode-value value element)))) (when (eq use 'encoded) (insert "</" (soap-element-fq-name op) ">\n")) (insert "</soap:Body>\n"))) -(defun soap-create-envelope (operation parameters wsdl) +(defun soap-create-envelope (operation parameters wsdl &optional service-url) "Create a SOAP request envelope for OPERATION using PARAMETERS. -WSDL is the wsdl document used to encode the PARAMETERS." +WSDL is the wsdl document used to encode the PARAMETERS. +SERVICE-URL should be provided when WS-Addressing is being used." (with-temp-buffer (let ((soap-encoded-namespaces '("xsi" "soap" "soapenc")) (use (soap-bound-operation-use operation))) ;; Create the request body - (soap-encode-body operation parameters wsdl) + (soap-encode-body operation parameters service-url) ;; Put the envelope around the body (goto-char (point-min)) (insert "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<soap:Envelope\n") (when (eq use 'encoded) - (insert " soapenc:encodingStyle=\"http://schemas.xmlsoap.org/soap/encoding/\"\n")) + (insert " soapenc:encodingStyle=\"\ +http://schemas.xmlsoap.org/soap/encoding/\"\n")) (dolist (nstag soap-encoded-namespaces) (insert " xmlns:" nstag "=\"") (let ((nsname (cdr (assoc nstag soap-well-known-xmlns)))) (unless nsname (setq nsname (cdr (assoc nstag (soap-wsdl-alias-table wsdl))))) (insert nsname) - (insert "\"\n"))) + (insert "\"\n"))) (insert ">\n") (goto-char (point-max)) (insert "</soap:Envelope>\n")) @@ -1730,6 +2990,86 @@ WSDL is the wsdl document used to encode the PARAMETERS." :type 'boolean :group 'soap-client) +(defun soap-invoke-internal (callback cbargs wsdl service operation-name + &rest parameters) + "Implement `soap-invoke' and `soap-invoke-async'. +If CALLBACK is non-nil, operate asynchronously, then call CALLBACK as (apply +CALLBACK RESPONSE CBARGS), where RESPONSE is the SOAP invocation result. +If CALLBACK is nil, operate synchronously. WSDL, SERVICE, +OPERATION-NAME and PARAMETERS are as described in `soap-invoke'." + (let ((port (catch 'found + (dolist (p (soap-wsdl-ports wsdl)) + (when (equal service (soap-element-name p)) + (throw 'found p)))))) + (unless port + (error "Unknown SOAP service: %s" service)) + + (let* ((binding (soap-port-binding port)) + (operation (gethash operation-name + (soap-binding-operations binding)))) + (unless operation + (error "No operation %s for SOAP service %s" operation-name service)) + + (let ((url-request-method "POST") + (url-package-name "soap-client.el") + (url-package-version "1.0") + (url-request-data + ;; url-request-data expects a unibyte string already encoded... + (encode-coding-string + (soap-create-envelope operation parameters wsdl + (soap-port-service-url port)) + 'utf-8)) + (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5") + (url-http-attempt-keepalives t) + (url-request-extra-headers + (list + (cons "SOAPAction" + (concat "\"" (soap-bound-operation-soap-action + operation) "\"")) + (cons "Content-Type" + "text/xml; charset=utf-8")))) + (if callback + (url-retrieve + (soap-port-service-url port) + (lambda (status) + (let ((data-buffer (current-buffer))) + (unwind-protect + (let ((error-status (plist-get status :error))) + (if error-status + (signal (car error-status) (cdr error-status)) + (apply callback + (soap-parse-envelope + (soap-parse-server-response) + operation wsdl) + cbargs))) + ;; Ensure the url-retrieve buffer is not leaked. + (and (buffer-live-p data-buffer) + (kill-buffer data-buffer)))))) + (let ((buffer (url-retrieve-synchronously + (soap-port-service-url port)))) + (condition-case err + (with-current-buffer buffer + (declare (special url-http-response-status)) + (if (null url-http-response-status) + (error "No HTTP response from server")) + (if (and soap-debug (> url-http-response-status 299)) + ;; This is a warning because some SOAP errors come + ;; back with a HTTP response 500 (internal server + ;; error) + (warn "Error in SOAP response: HTTP code %s" + url-http-response-status)) + (soap-parse-envelope (soap-parse-server-response) + operation wsdl)) + (soap-error + ;; Propagate soap-errors -- they are error replies of the + ;; SOAP protocol and don't indicate a communication + ;; problem or a bug in this code. + (signal (car err) (cdr err))) + (error + (when soap-debug + (pop-to-buffer buffer)) + (error (error-message-string err)))))))))) + (defun soap-invoke (wsdl service operation-name &rest parameters) "Invoke a SOAP operation and return the result. @@ -1748,79 +3088,25 @@ NOTE: The SOAP service provider should document the available operations and their parameters for the service. You can also use the `soap-inspect' function to browse the available operations in a WSDL document." - (let ((port (catch 'found - (dolist (p (soap-wsdl-ports wsdl)) - (when (equal service (soap-element-name p)) - (throw 'found p)))))) - (unless port - (error "Unknown SOAP service: %s" service)) - - (let* ((binding (soap-port-binding port)) - (operation (gethash operation-name - (soap-binding-operations binding)))) - (unless operation - (error "No operation %s for SOAP service %s" operation-name service)) - - (let ((url-request-method "POST") - (url-package-name "soap-client.el") - (url-package-version "1.0") - (url-http-version "1.0") - (url-request-data - ;; url-request-data expects a unibyte string already encoded... - (encode-coding-string - (soap-create-envelope operation parameters wsdl) - 'utf-8)) - (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5") - (url-request-coding-system 'utf-8) - (url-http-attempt-keepalives t) - (url-request-extra-headers (list - (cons "SOAPAction" - (soap-bound-operation-soap-action - operation)) - (cons "Content-Type" - "text/xml; charset=utf-8")))) - (let ((buffer (url-retrieve-synchronously - (soap-port-service-url port)))) - (condition-case err - (with-current-buffer buffer - (declare (special url-http-response-status)) - (if (null url-http-response-status) - (error "No HTTP response from server")) - (if (and soap-debug (> url-http-response-status 299)) - ;; This is a warning because some SOAP errors come - ;; back with a HTTP response 500 (internal server - ;; error) - (warn "Error in SOAP response: HTTP code %s" - url-http-response-status)) - (let ((mime-part (mm-dissect-buffer t t))) - (unless mime-part - (error "Failed to decode response from server")) - (unless (equal (car (mm-handle-type mime-part)) "text/xml") - (error "Server response is not an XML document")) - (with-temp-buffer - (mm-insert-part mime-part) - (let ((response (car (xml-parse-region - (point-min) (point-max))))) - (prog1 - (soap-parse-envelope response operation wsdl) - (kill-buffer buffer) - (mm-destroy-part mime-part)))))) - (soap-error - ;; Propagate soap-errors -- they are error replies of the - ;; SOAP protocol and don't indicate a communication - ;; problem or a bug in this code. - (signal (car err) (cdr err))) - (error - (when soap-debug - (pop-to-buffer buffer)) - (error (error-message-string err))))))))) + (apply #'soap-invoke-internal nil nil wsdl service operation-name parameters)) + +(defun soap-invoke-async (callback cbargs wsdl service operation-name + &rest parameters) + "Like `soap-invoke', but call CALLBACK asynchronously with response. +CALLBACK is called as (apply CALLBACK RESPONSE CBARGS), where +RESPONSE is the SOAP invocation result. WSDL, SERVICE, +OPERATION-NAME and PARAMETERS are as described in `soap-invoke'." + (unless callback + (error "Callback argument is nil")) + (apply #'soap-invoke-internal callback cbargs wsdl service operation-name + parameters)) (provide 'soap-client) -;;; Local Variables: -;;; eval: (outline-minor-mode 1) -;;; outline-regexp: ";;;;+" -;;; End: +;; Local Variables: +;; eval: (outline-minor-mode 1) +;; outline-regexp: ";;;;+" +;; End: ;;; soap-client.el ends here diff --git a/lisp/net/soap-inspect.el b/lisp/net/soap-inspect.el index 874a68588c7..f6c7da6c7cd 100644 --- a/lisp/net/soap-inspect.el +++ b/lisp/net/soap-inspect.el @@ -1,12 +1,13 @@ -;;;; soap-inspect.el -- Interactive inspector for soap WSDL structures +;;;; soap-inspect.el -- Interactive WSDL inspector -*- lexical-binding: t -*- -;; Copyright (C) 2010-2013 Free Software Foundation, Inc. +;; Copyright (C) 2010-2015 Free Software Foundation, Inc. ;; Author: Alexandru Harsanyi <AlexHarsanyi@gmail.com> ;; Created: October 2010 +;; Version: 3.0.1 ;; Keywords: soap, web-services, comm, hypermedia ;; Package: soap-client -;; Homepage: http://code.google.com/p/emacs-soap-client +;; Homepage: https://github.com/alex-hhh/emacs-soap-client ;; This file is part of GNU Emacs. @@ -55,86 +56,153 @@ will be called." (funcall sample-value type) (error "Cannot provide sample value for type %s" (aref type 0))))) -(defun soap-sample-value-for-basic-type (type) - "Provide a sample value for TYPE which is a basic type. -This is a specific function which should not be called directly, -use `soap-sample-value' instead." - (case (soap-basic-type-kind type) - (string "a string value") - (boolean t) ; could be nil as well - ((long int) (random 4200)) - ;; TODO: we need better sample values for more types. - (t (format "%s" (soap-basic-type-kind type))))) - -(defun soap-sample-value-for-simple-type (type) - "Provide a sample value for TYPE which is a simple type. -This is a specific function which should not be called directly, -use `soap-sample-value' instead." - (let ((enumeration (soap-simple-type-enumeration type))) - (if (> (length enumeration) 1) - (elt enumeration (random (length enumeration))) - (soap-sample-value-for-basic-type type)))) - -(defun soap-sample-value-for-seqence-type (type) - "Provide a sample value for TYPE which is a sequence type. -Values for sequence types are ALISTS of (slot-name . VALUE) for -each sequence element. - -This is a specific function which should not be called directly, -use `soap-sample-value' instead." - (let ((sample-value nil)) - (dolist (element (soap-sequence-type-elements type)) - (push (cons (soap-sequence-element-name element) - (soap-sample-value (soap-sequence-element-type element))) - sample-value)) - (when (soap-sequence-type-parent type) - (setq sample-value - (append (soap-sample-value (soap-sequence-type-parent type)) - sample-value))) - sample-value)) - -(defun soap-sample-value-for-array-type (type) - "Provide a sample value for TYPE which is an array type. -Values for array types are LISP vectors of values which are -array's element type. - -This is a specific function which should not be called directly, -use `soap-sample-value' instead." - (let* ((element-type (soap-array-type-element-type type)) - (sample1 (soap-sample-value element-type)) - (sample2 (soap-sample-value element-type))) - ;; Our sample value is a vector of two elements, but any number of - ;; elements are permissible - (vector sample1 sample2 '&etc))) +(defun soap-sample-value-for-xs-basic-type (type) + "Provide a sample value for TYPE, an xs-basic-type. +This is a specialization of `soap-sample-value' for xs-basic-type +objects." + (case (soap-xs-basic-type-kind type) + (string "a string") + (anyURI "an URI") + (QName "a QName") + (dateTime "a time-value-p or string") + (boolean "t or nil") + ((long int integer byte unsignedInt) 42) + ((float double) 3.14) + (base64Binary "a string") + (t (format "%s" (soap-xs-basic-type-kind type))))) + +(defun soap-sample-value-for-xs-element (element) + "Provide a sample value for ELEMENT, a WSDL element. +This is a specialization of `soap-sample-value' for xs-element +objects." + (if (soap-xs-element-name element) + (cons (intern (soap-xs-element-name element)) + (soap-sample-value (soap-xs-element-type element))) + (soap-sample-value (soap-xs-element-type element)))) + +(defun soap-sample-value-for-xs-attribute (attribute) + "Provide a sample value for ATTRIBUTE, a WSDL attribute. +This is a specialization of `soap-sample-value' for +soap-xs-attribute objects." + (if (soap-xs-attribute-name attribute) + (cons (intern (soap-xs-attribute-name attribute)) + (soap-sample-value (soap-xs-attribute-type attribute))) + (soap-sample-value (soap-xs-attribute-type attribute)))) + +(defun soap-sample-value-for-xs-attribute-group (attribute-group) + "Provide a sample value for ATTRIBUTE-GROUP, a WSDL attribute group. +This is a specialization of `soap-sample-value' for +soap-xs-attribute objects." + (let ((sample-values nil)) + (dolist (attribute (soap-xs-attribute-group-attributes attribute-group)) + (if (soap-xs-attribute-name attribute) + (setq sample-values + (append sample-values + (cons (intern (soap-xs-attribute-name attribute)) + (soap-sample-value (soap-xs-attribute-type + attribute))))) + (setq sample-values + (append sample-values + (soap-sample-value + (soap-xs-attribute-type attribute)))))))) + +(defun soap-sample-value-for-xs-simple-type (type) + "Provide a sample value for TYPE, a `soap-xs-simple-type'. +This is a specialization of `soap-sample-value' for +`soap-xs-simple-type' objects." + (append + (mapcar 'soap-sample-value-for-xs-attribute + (soap-xs-type-attributes type)) + (cond + ((soap-xs-simple-type-enumeration type) + (let ((enumeration (soap-xs-simple-type-enumeration type))) + (nth (random (length enumeration)) enumeration))) + ((soap-xs-simple-type-pattern type) + (format "a string matching %s" (soap-xs-simple-type-pattern type))) + ((soap-xs-simple-type-length-range type) + (destructuring-bind (low . high) (soap-xs-simple-type-length-range type) + (cond + ((and low high) + (format "a string between %d and %d chars long" low high)) + (low (format "a string at least %d chars long" low)) + (high (format "a string at most %d chars long" high)) + (t (format "a string OOPS"))))) + ((soap-xs-simple-type-integer-range type) + (destructuring-bind (min . max) (soap-xs-simple-type-integer-range type) + (cond + ((and min max) (+ min (random (- max min)))) + (min (+ min (random 10))) + (max (random max)) + (t (random 100))))) + ((consp (soap-xs-simple-type-base type)) ; an union of values + (let ((base (soap-xs-simple-type-base type))) + (soap-sample-value (nth (random (length base)) base)))) + ((soap-xs-basic-type-p (soap-xs-simple-type-base type)) + (soap-sample-value (soap-xs-simple-type-base type)))))) + +(defun soap-sample-value-for-xs-complex-type (type) + "Provide a sample value for TYPE, a `soap-xs-complex-type'. +This is a specialization of `soap-sample-value' for +`soap-xs-complex-type' objects." + (append + (mapcar 'soap-sample-value-for-xs-attribute + (soap-xs-type-attributes type)) + (case (soap-xs-complex-type-indicator type) + (array + (let* ((element-type (soap-xs-complex-type-base type)) + (sample1 (soap-sample-value element-type)) + (sample2 (soap-sample-value element-type))) + ;; Our sample value is a vector of two elements, but any number of + ;; elements are permissible + (vector sample1 sample2 '&etc))) + ((sequence choice all) + (let ((base (soap-xs-complex-type-base type))) + (let ((value (append (and base (soap-sample-value base)) + (mapcar #'soap-sample-value + (soap-xs-complex-type-elements type))))) + (if (eq (soap-xs-complex-type-indicator type) 'choice) + (cons '***choice-of*** value) + value))))))) (defun soap-sample-value-for-message (message) "Provide a sample value for a WSDL MESSAGE. -This is a specific function which should not be called directly, -use `soap-sample-value' instead." +This is a specialization of `soap-sample-value' for +`soap-message' objects." ;; NOTE: parameter order is not considered. (let (sample-value) (dolist (part (soap-message-parts message)) - (push (cons (car part) - (soap-sample-value (cdr part))) - sample-value)) + (push (soap-sample-value (cdr part)) sample-value)) (nreverse sample-value))) (progn ;; Install soap-sample-value methods for our types - (put (aref (make-soap-basic-type) 0) 'soap-sample-value - 'soap-sample-value-for-basic-type) + (put (aref (make-soap-xs-basic-type) 0) + 'soap-sample-value + 'soap-sample-value-for-xs-basic-type) - (put (aref (make-soap-simple-type) 0) 'soap-sample-value - 'soap-sample-value-for-simple-type) + (put (aref (make-soap-xs-element) 0) + 'soap-sample-value + 'soap-sample-value-for-xs-element) - (put (aref (make-soap-sequence-type) 0) 'soap-sample-value - 'soap-sample-value-for-seqence-type) + (put (aref (make-soap-xs-attribute) 0) + 'soap-sample-value + 'soap-sample-value-for-xs-attribute) - (put (aref (make-soap-array-type) 0) 'soap-sample-value - 'soap-sample-value-for-array-type) + (put (aref (make-soap-xs-attribute) 0) + 'soap-sample-value + 'soap-sample-value-for-xs-attribute-group) - (put (aref (make-soap-message) 0) 'soap-sample-value - 'soap-sample-value-for-message) ) + (put (aref (make-soap-xs-simple-type) 0) + 'soap-sample-value + 'soap-sample-value-for-xs-simple-type) + + (put (aref (make-soap-xs-complex-type) 0) + 'soap-sample-value + 'soap-sample-value-for-xs-complex-type) + + (put (aref (make-soap-message) 0) + 'soap-sample-value + 'soap-sample-value-for-message)) @@ -184,7 +252,7 @@ entire WSDL can be inspected." (define-button-type 'soap-client-describe-link - 'face 'italic + 'face 'link 'help-echo "mouse-2, RET: describe item" 'follow-link t 'action (lambda (button) @@ -193,10 +261,10 @@ entire WSDL can be inspected." 'skip t) (define-button-type 'soap-client-describe-back-link - 'face 'italic + 'face 'link 'help-echo "mouse-2, RET: browse the previous item" 'follow-link t - 'action (lambda (button) + 'action (lambda (_button) (let ((item (pop soap-inspect-previous-items))) (when item (setq soap-inspect-current-item nil) @@ -210,52 +278,142 @@ entire WSDL can be inspected." 'type 'soap-client-describe-link 'item element)) -(defun soap-inspect-basic-type (basic-type) - "Insert information about BASIC-TYPE into the current buffer." - (insert "Basic type: " (soap-element-fq-name basic-type)) - (insert "\nSample value\n") - (pp (soap-sample-value basic-type) (current-buffer))) - -(defun soap-inspect-simple-type (simple-type) - "Insert information about SIMPLE-TYPE into the current buffer" - (insert "Simple type: " (soap-element-fq-name simple-type) "\n") - (insert "Base: " (symbol-name (soap-basic-type-kind simple-type)) "\n") - (let ((enumeration (soap-simple-type-enumeration simple-type))) - (when (> (length enumeration) 1) - (insert "Valid values: ") - (dolist (e enumeration) - (insert "\"" e "\" "))))) - -(defun soap-inspect-sequence-type (sequence) - "Insert information about SEQUENCE into the current buffer." - (insert "Sequence type: " (soap-element-fq-name sequence) "\n") - (when (soap-sequence-type-parent sequence) - (insert "Parent: ") - (soap-insert-describe-button - (soap-sequence-type-parent sequence)) - (insert "\n")) - (insert "Elements: \n") - (dolist (element (soap-sequence-type-elements sequence)) - (insert "\t" (symbol-name (soap-sequence-element-name element)) - "\t") - (soap-insert-describe-button - (soap-sequence-element-type element)) - (when (soap-sequence-element-multiple? element) - (insert " multiple")) - (when (soap-sequence-element-nillable? element) - (insert " optional")) - (insert "\n")) - (insert "Sample value:\n") - (pp (soap-sample-value sequence) (current-buffer))) - -(defun soap-inspect-array-type (array) - "Insert information about the ARRAY into the current buffer." - (insert "Array name: " (soap-element-fq-name array) "\n") - (insert "Element type: ") - (soap-insert-describe-button - (soap-array-type-element-type array)) +(defun soap-inspect-xs-basic-type (type) + "Insert information about TYPE, a soap-xs-basic-type, in the current buffer." + (insert "Basic type: " (soap-element-fq-name type)) + (insert "\nSample value:\n") + (pp (soap-sample-value type) (current-buffer))) + +(defun soap-inspect-xs-element (element) + "Insert information about ELEMENT, a soap-xs-element, in the current buffer." + (insert "Element: " (soap-element-fq-name element)) + (insert "\nType: ") + (soap-insert-describe-button (soap-xs-element-type element)) + (insert "\nAttributes:") + (when (soap-xs-element-optional? element) + (insert " optional")) + (when (soap-xs-element-multiple? element) + (insert " multiple")) + (insert "\nSample value:\n") + (pp (soap-sample-value element) (current-buffer))) + +(defun soap-inspect-xs-attribute (attribute) + "Insert information about ATTRIBUTE, a soap-xs-attribute, in +the current buffer." + (insert "Attribute: " (soap-element-fq-name attribute)) + (insert "\nType: ") + (soap-insert-describe-button (soap-xs-attribute-type attribute)) (insert "\nSample value:\n") - (pp (soap-sample-value array) (current-buffer))) + (pp (soap-sample-value attribute) (current-buffer))) + +(defun soap-inspect-xs-attribute-group (attribute-group) + "Insert information about ATTRIBUTE-GROUP, a +soap-xs-attribute-group, in the current buffer." + (insert "Attribute group: " (soap-element-fq-name attribute-group)) + (insert "\nSample values:\n") + (pp (soap-sample-value attribute-group) (current-buffer))) + +(defun soap-inspect-xs-simple-type (type) + "Insert information about TYPE, a soap-xs-simple-type, in the current buffer." + (insert "Simple type: " (soap-element-fq-name type)) + (insert "\nBase: " ) + (if (listp (soap-xs-simple-type-base type)) + (let ((first-time t)) + (dolist (b (soap-xs-simple-type-base type)) + (unless first-time + (insert ", ") + (setq first-time nil)) + (soap-insert-describe-button b))) + (soap-insert-describe-button (soap-xs-simple-type-base type))) + (insert "\nAttributes: ") + (dolist (attribute (soap-xs-simple-type-attributes type)) + (let ((name (or (soap-xs-attribute-name attribute) "*inline*")) + (type (soap-xs-attribute-type attribute))) + (insert "\n\t") + (insert name) + (insert "\t") + (soap-insert-describe-button type))) + (when (soap-xs-simple-type-enumeration type) + (insert "\nEnumeraton values: ") + (dolist (e (soap-xs-simple-type-enumeration type)) + (insert "\n\t") + (pp e))) + (when (soap-xs-simple-type-pattern type) + (insert "\nPattern: " (soap-xs-simple-type-pattern type))) + (when (car (soap-xs-simple-type-length-range type)) + (insert "\nMin length: " + (number-to-string (car (soap-xs-simple-type-length-range type))))) + (when (cdr (soap-xs-simple-type-length-range type)) + (insert "\nMin length: " + (number-to-string (cdr (soap-xs-simple-type-length-range type))))) + (when (car (soap-xs-simple-type-integer-range type)) + (insert "\nMin value: " + (number-to-string (car (soap-xs-simple-type-integer-range type))))) + (when (cdr (soap-xs-simple-type-integer-range type)) + (insert "\nMin value: " + (number-to-string (cdr (soap-xs-simple-type-integer-range type))))) + (insert "\nSample value:\n") + (pp (soap-sample-value type) (current-buffer))) + +(defun soap-inspect-xs-complex-type (type) + "Insert information about TYPE in the current buffer. +TYPE is a `soap-xs-complex-type'" + (insert "Complex type: " (soap-element-fq-name type)) + (insert "\nKind: ") + (case (soap-xs-complex-type-indicator type) + ((sequence all) + (insert "a sequence ") + (when (soap-xs-complex-type-base type) + (insert "extending ") + (soap-insert-describe-button (soap-xs-complex-type-base type))) + (insert "\nAttributes: ") + (dolist (attribute (soap-xs-complex-type-attributes type)) + (let ((name (or (soap-xs-attribute-name attribute) "*inline*")) + (type (soap-xs-attribute-type attribute))) + (insert "\n\t") + (insert name) + (insert "\t") + (soap-insert-describe-button type))) + (insert "\nElements: ") + (let ((name-width 0) + (type-width 0)) + (dolist (element (soap-xs-complex-type-elements type)) + (let ((name (or (soap-xs-element-name element) "*inline*")) + (type (soap-xs-element-type element))) + (setq name-width (max name-width (length name))) + (setq type-width + (max type-width (length (soap-element-fq-name type)))))) + (setq name-width (+ name-width 2)) + (setq type-width (+ type-width 2)) + (dolist (element (soap-xs-complex-type-elements type)) + (let ((name (or (soap-xs-element-name element) "*inline*")) + (type (soap-xs-element-type element))) + (insert "\n\t") + (insert name) + (insert (make-string (- name-width (length name)) ?\ )) + (soap-insert-describe-button type) + (insert + (make-string + (- type-width (length (soap-element-fq-name type))) ?\ )) + (when (soap-xs-element-multiple? element) + (insert " multiple")) + (when (soap-xs-element-optional? element) + (insert " optional")))))) + (choice + (insert "a choice ") + (when (soap-xs-complex-type-base type) + (insert "extending ") + (soap-insert-describe-button (soap-xs-complex-type-base type))) + (insert "\nElements: ") + (dolist (element (soap-xs-complex-type-elements type)) + (insert "\n\t") + (soap-insert-describe-button element))) + (array + (insert "an array of ") + (soap-insert-describe-button (soap-xs-complex-type-base type)))) + (insert "\nSample value:\n") + (pp (soap-sample-value type) (current-buffer))) + (defun soap-inspect-message (message) "Insert information about MESSAGE into the current buffer." @@ -281,10 +439,11 @@ entire WSDL can be inspected." (insert "\n\nSample invocation:\n") (let ((sample-message-value - (soap-sample-value (cdr (soap-operation-input operation)))) - (funcall (list 'soap-invoke '*WSDL* "SomeService" (soap-element-name operation)))) + (soap-sample-value (cdr (soap-operation-input operation)))) + (funcall (list 'soap-invoke '*WSDL* "SomeService" + (soap-element-name operation)))) (let ((sample-invocation - (append funcall (mapcar 'cdr sample-message-value)))) + (append funcall (mapcar 'cdr sample-message-value)))) (pp sample-invocation (current-buffer))))) (defun soap-inspect-port-type (port-type) @@ -350,17 +509,23 @@ entire WSDL can be inspected." (progn ;; Install the soap-inspect methods for our types - (put (aref (make-soap-basic-type) 0) 'soap-inspect - 'soap-inspect-basic-type) + (put (aref (make-soap-xs-basic-type) 0) 'soap-inspect + 'soap-inspect-xs-basic-type) + + (put (aref (make-soap-xs-element) 0) 'soap-inspect + 'soap-inspect-xs-element) + + (put (aref (make-soap-xs-simple-type) 0) 'soap-inspect + 'soap-inspect-xs-simple-type) - (put (aref (make-soap-simple-type) 0) 'soap-inspect - 'soap-inspect-simple-type) + (put (aref (make-soap-xs-complex-type) 0) 'soap-inspect + 'soap-inspect-xs-complex-type) - (put (aref (make-soap-sequence-type) 0) 'soap-inspect - 'soap-inspect-sequence-type) + (put (aref (make-soap-xs-attribute) 0) 'soap-inspect + 'soap-inspect-xs-attribute) - (put (aref (make-soap-array-type) 0) 'soap-inspect - 'soap-inspect-array-type) + (put (aref (make-soap-xs-attribute-group) 0) 'soap-inspect + 'soap-inspect-xs-attribute-group) (put (aref (make-soap-message) 0) 'soap-inspect 'soap-inspect-message) @@ -376,7 +541,7 @@ entire WSDL can be inspected." (put (aref (make-soap-port) 0) 'soap-inspect 'soap-inspect-port) - (put (aref (make-soap-wsdl) 0) 'soap-inspect + (put (aref (soap-make-wsdl "origin") 0) 'soap-inspect 'soap-inspect-wsdl)) (provide 'soap-inspect) diff --git a/lisp/net/socks.el b/lisp/net/socks.el index d6173e01ecd..db9579573f6 100644 --- a/lisp/net/socks.el +++ b/lisp/net/socks.el @@ -1,6 +1,6 @@ ;;; socks.el --- A Socks v5 Client for Emacs -;; Copyright (C) 1996-2000, 2002, 2007-2013 Free Software Foundation, +;; Copyright (C) 1996-2000, 2002, 2007-2015 Free Software Foundation, ;; Inc. ;; Author: William M. Perry <wmperry@gnu.org> @@ -102,7 +102,7 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." ;;; Customization support ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgroup socks nil - "SOCKS Support" + "SOCKS support." :version "22.2" :prefix "socks-" :group 'processes) @@ -347,7 +347,7 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." ;; could get a wrapper hook, or defer to open-network-stream-function. (defvar socks-override-functions nil - "Whether to overwrite the open-network-stream function with the SOCKSified + "Whether to overwrite the `open-network-stream' function with the SOCKSified version.") (require 'network-stream) @@ -533,7 +533,7 @@ version.") socks-tcp-services)))))) (defun socks-find-services-entry (service &optional udp) - "Return the port # associated with SERVICE" + "Return the port # associated with SERVICE." (if (= (hash-table-count socks-tcp-services) 0) (socks-parse-services)) (gethash (downcase service) diff --git a/lisp/net/telnet.el b/lisp/net/telnet.el index e3c42f59315..6d9f408d5ca 100644 --- a/lisp/net/telnet.el +++ b/lisp/net/telnet.el @@ -1,10 +1,10 @@ ;;; telnet.el --- run a telnet session from within an Emacs buffer -;; Copyright (C) 1985, 1988, 1992, 1994, 2001-2013 Free Software +;; Copyright (C) 1985, 1988, 1992, 1994, 2001-2015 Free Software ;; Foundation, Inc. ;; Author: William F. Schelter -;; Maintainer: FSF +;; Maintainer: emacs-devel@gnu.org ;; Keywords: unix, comm ;; This file is part of GNU Emacs. @@ -237,7 +237,7 @@ Normally input is edited in Emacs and sent a line at a time." (define-derived-mode telnet-mode comint-mode "Telnet" "This mode is for using telnet (or rsh) from a buffer to another host. It has most of the same commands as comint-mode. -There is a variable ``telnet-interrupt-string'' which is the character +There is a variable `telnet-interrupt-string' which is the character sent to try to stop execution of a job on the remote host. Data is sent to the remote host when RET is typed." (set (make-local-variable 'window-point-insertion-type) t) diff --git a/lisp/net/tls.el b/lisp/net/tls.el index 3d8d8decf47..48e6a42186c 100644 --- a/lisp/net/tls.el +++ b/lisp/net/tls.el @@ -1,6 +1,6 @@ ;;; tls.el --- TLS/SSL support via wrapper around GnuTLS -;; Copyright (C) 1996-1999, 2002-2013 Free Software Foundation, Inc. +;; Copyright (C) 1996-1999, 2002-2015 Free Software Foundation, Inc. ;; Author: Simon Josefsson <simon@josefsson.org> ;; Keywords: comm, tls, gnutls, ssl @@ -80,8 +80,7 @@ and `gnutls-cli' (version 2.0.1) output." "List of strings containing commands to start TLS stream to a host. Each entry in the list is tried until a connection is successful. %h is replaced with server hostname, %p with port to connect to. -The program should read input on stdin and write output to -stdout. +The program should read input on stdin and write output to stdout. See `tls-checktrust' on how to check trusted root certs. @@ -138,7 +137,7 @@ the external program knows about the root certificates you consider trustworthy, e.g.: \(setq tls-program - '(\"gnutls-cli --x509cafile /etc/ssl/certs/ca-certificates.crt -p %p %h\" + \\='(\"gnutls-cli --x509cafile /etc/ssl/certs/ca-certificates.crt -p %p %h\" \"gnutls-cli --x509cafile /etc/ssl/certs/ca-certificates.crt -p %p %h --protocols ssl3\" \"openssl s_client -connect %h:%p -CAfile /etc/ssl/certs/ca-certificates.crt -no_ssl2 -ign_eof\"))" :type '(choice (const :tag "Always" t) @@ -168,13 +167,18 @@ this to nil if you want to ignore host name mismatches." :version "23.1" ;; No Gnus :group 'tls) -(defcustom tls-certtool-program (executable-find "certtool") - "Name of GnuTLS certtool. +(defcustom tls-certtool-program "certtool" + "Name of GnuTLS certtool. Used by `tls-certificate-information'." :version "22.1" :type 'string :group 'tls) +(defalias 'tls-format-message + (if (fboundp 'format-message) 'format-message + ;; for Emacs < 25, and XEmacs, don't worry about quote translation. + 'format)) + (defun tls-certificate-information (der) "Parse X.509 certificate in DER format into an assoc list." (let ((certificate (concat "-----BEGIN CERTIFICATE-----\n" @@ -276,8 +280,8 @@ Fourth arg PORT is an integer specifying a port to connect to." (message "The certificate presented by `%s' is \ NOT trusted." host)) (not (yes-or-no-p - (format "The certificate presented by `%s' is \ -NOT trusted. Accept anyway? " host))))) + (tls-format-message "\ +The certificate presented by `%s' is NOT trusted. Accept anyway? " host))))) (and tls-hostmismatch (save-excursion (goto-char (point-min)) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 8ddbe254380..88dea6a7e35 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -1,8 +1,8 @@ ;;; tramp-adb.el --- Functions for calling Android Debug Bridge from Tramp -;; Copyright (C) 2011-2013 Free Software Foundation, Inc. +;; Copyright (C) 2011-2015 Free Software Foundation, Inc. -;; Author: Juergen Hoetzel <juergen@archlinux.org> +;; Author: Jürgen Hötzel <juergen@archlinux.org> ;; Keywords: comm, processes ;; Package: tramp @@ -34,12 +34,12 @@ ;;; Code: (require 'tramp) -(require 'time-date) ;; Pacify byte-compiler. +(defvar directory-listing-before-filename-regexp) (defvar directory-sep-char) -(defvar dired-move-to-filename-regexp) +;;;###tramp-autoload (defcustom tramp-adb-program "adb" "Name of the Android Debug Bridge program." :group 'tramp @@ -47,11 +47,20 @@ :type 'string) ;;;###tramp-autoload +(defcustom tramp-adb-connect-if-not-connected nil + "Try to run `adb connect' if provided device is not connected currently. +It is used for TCP/IP devices." + :group 'tramp + :version "25.1" + :type 'boolean) + +;;;###tramp-autoload (defconst tramp-adb-method "adb" "*When this method name is used, forward all calls to Android Debug Bridge.") +;;;###tramp-autoload (defcustom tramp-adb-prompt - "^\\(?:[[:digit:]]*|?\\)?\\(?:[[:alnum:]]*@[[:alnum:]]*[^#\\$]*\\)?[#\\$][[:space:]]" + "^\\(?:[[:digit:]]*|?\\)?\\(?:[[:alnum:]\e;[]*@[[:alnum:]]*[^#\\$]*\\)?[#\\$][[:space:]]" "Regexp used as prompt in almquist shell." :type 'string :version "24.4" @@ -67,12 +76,13 @@ "[[:space:]]+\\([^[:space:]]+\\)" ; \3 group "[[:space:]]+\\([[:digit:]]+\\)" ; \4 size "[[:space:]]+\\([-[:digit:]]+[[:space:]][:[:digit:]]+\\)" ; \5 date - "[[:space:]]+\\(.*\\)$")) ; \6 filename + "[[:space:]]\\(.*\\)$")) ; \6 filename ;;;###tramp-autoload (add-to-list 'tramp-methods `(,tramp-adb-method - (tramp-tmpdir "/data/local/tmp"))) + (tramp-tmpdir "/data/local/tmp") + (tramp-default-port 5555))) ;;;###tramp-autoload (add-to-list 'tramp-default-host-alist `(,tramp-adb-method nil "")) @@ -123,6 +133,7 @@ (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) (file-notify-add-watch . tramp-handle-file-notify-add-watch) (file-notify-rm-watch . tramp-handle-file-notify-rm-watch) + (file-notify-valid-p . tramp-handle-file-notify-valid-p) (file-ownership-preserved-p . ignore) (file-readable-p . tramp-handle-file-exists-p) (file-regular-p . tramp-handle-file-regular-p) @@ -134,13 +145,13 @@ (find-backup-file-name . tramp-handle-find-backup-file-name) ;; `find-file-noselect' performed by default handler. ;; `get-file-buffer' performed by default handler. - (insert-directory . tramp-adb-handle-insert-directory) + (insert-directory . tramp-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) (load . tramp-handle-load) - ;; `make-auto-save-file-name' performed by default handler. + (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-adb-handle-make-directory) (make-directory-internal . ignore) - (make-symbolic-link . ignore) + (make-symbolic-link . tramp-handle-make-symbolic-link) (process-file . tramp-adb-handle-process-file) (rename-file . tramp-adb-handle-rename-file) (set-file-acl . ignore) @@ -184,13 +195,27 @@ pass to the OPERATION." ;; That's why we use `start-process'. (let ((p (start-process tramp-adb-program (current-buffer) tramp-adb-program "devices")) + (v (vector tramp-adb-method tramp-current-user + tramp-current-host nil nil)) result) + (tramp-message v 6 "%s" (mapconcat 'identity (process-command p) " ")) (tramp-compat-set-process-query-on-exit-flag p nil) (while (eq 'run (process-status p)) - (sleep-for 0.1)) + (accept-process-output p 0.1)) + (accept-process-output p 0.1) + (tramp-message v 6 "\n%s" (buffer-string)) (goto-char (point-min)) (while (search-forward-regexp "^\\(\\S-+\\)[[:space:]]+device$" nil t) (add-to-list 'result (list nil (match-string 1)))) + + ;; Replace ":" by "#". + (mapc + (lambda (elt) + (setcar + (cdr elt) + (tramp-compat-replace-regexp-in-string + ":" tramp-prefix-port-format (car (cdr elt))))) + result) result)))) (defun tramp-adb-handle-expand-file-name (name &optional dir) @@ -228,83 +253,90 @@ pass to the OPERATION." ;; code could be shared? (defun tramp-adb-handle-file-truename (filename) "Like `file-truename' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-tramp-file-property v localname "file-truename" - (let ((result nil)) ; result steps in reverse order - (tramp-message v 4 "Finding true name for `%s'" filename) - (let* ((directory-sep-char ?/) - (steps (tramp-compat-split-string localname "/")) - (localnamedir (tramp-run-real-handler - 'file-name-as-directory (list localname))) - (is-dir (string= localname localnamedir)) - (thisstep nil) - (numchase 0) - ;; Don't make the following value larger than - ;; necessary. People expect an error message in a - ;; timely fashion when something is wrong; otherwise - ;; they might think that Emacs is hung. Of course, - ;; correctness has to come first. - (numchase-limit 20) - symlink-target) - (while (and steps (< numchase numchase-limit)) - (setq thisstep (pop steps)) - (tramp-message - v 5 "Check %s" - (mapconcat 'identity - (append '("") (reverse result) (list thisstep)) - "/")) - (setq symlink-target - (nth 0 (file-attributes - (tramp-make-tramp-file-name - method user host - (mapconcat 'identity - (append '("") - (reverse result) - (list thisstep)) - "/"))))) - (cond ((string= "." thisstep) - (tramp-message v 5 "Ignoring step `.'")) - ((string= ".." thisstep) - (tramp-message v 5 "Processing step `..'") - (pop result)) - ((stringp symlink-target) - ;; It's a symlink, follow it. - (tramp-message v 5 "Follow symlink to %s" symlink-target) - (setq numchase (1+ numchase)) - (when (file-name-absolute-p symlink-target) - (setq result nil)) - ;; If the symlink was absolute, we'll get a string - ;; like "/user@host:/some/target"; extract the - ;; "/some/target" part from it. - (when (tramp-tramp-file-p symlink-target) - (unless (tramp-equal-remote filename symlink-target) - (tramp-error - v 'file-error - "Symlink target `%s' on wrong host" symlink-target)) - (setq symlink-target localname)) - (setq steps - (append (tramp-compat-split-string - symlink-target "/") - steps))) - (t - ;; It's a file. - (setq result (cons thisstep result))))) - (when (>= numchase numchase-limit) - (tramp-error - v 'file-error - "Maximum number (%d) of symlinks exceeded" numchase-limit)) - (setq result (reverse result)) - ;; Combine list to form string. - (setq result - (if result - (mapconcat 'identity (cons "" result) "/") - "/")) - (when (and is-dir (or (string= "" result) - (not (string= (substring result -1) "/")))) - (setq result (concat result "/")))) - - (tramp-message v 4 "True name of `%s' is `%s'" filename result) - (tramp-make-tramp-file-name method user host result))))) + (format + "%s%s" + (with-parsed-tramp-file-name (expand-file-name filename) nil + (tramp-make-tramp-file-name + method user host + (with-tramp-file-property v localname "file-truename" + (let ((result nil)) ; result steps in reverse order + (tramp-message v 4 "Finding true name for `%s'" filename) + (let* ((directory-sep-char ?/) + (steps (tramp-compat-split-string localname "/")) + (localnamedir (tramp-run-real-handler + 'file-name-as-directory (list localname))) + (is-dir (string= localname localnamedir)) + (thisstep nil) + (numchase 0) + ;; Don't make the following value larger than + ;; necessary. People expect an error message in a + ;; timely fashion when something is wrong; otherwise + ;; they might think that Emacs is hung. Of course, + ;; correctness has to come first. + (numchase-limit 20) + symlink-target) + (while (and steps (< numchase numchase-limit)) + (setq thisstep (pop steps)) + (tramp-message + v 5 "Check %s" + (mapconcat 'identity + (append '("") (reverse result) (list thisstep)) + "/")) + (setq symlink-target + (nth 0 (file-attributes + (tramp-make-tramp-file-name + method user host + (mapconcat 'identity + (append '("") + (reverse result) + (list thisstep)) + "/"))))) + (cond ((string= "." thisstep) + (tramp-message v 5 "Ignoring step `.'")) + ((string= ".." thisstep) + (tramp-message v 5 "Processing step `..'") + (pop result)) + ((stringp symlink-target) + ;; It's a symlink, follow it. + (tramp-message v 5 "Follow symlink to %s" symlink-target) + (setq numchase (1+ numchase)) + (when (file-name-absolute-p symlink-target) + (setq result nil)) + ;; If the symlink was absolute, we'll get a string + ;; like "/user@host:/some/target"; extract the + ;; "/some/target" part from it. + (when (tramp-tramp-file-p symlink-target) + (unless (tramp-equal-remote filename symlink-target) + (tramp-error + v 'file-error + "Symlink target `%s' on wrong host" symlink-target)) + (setq symlink-target localname)) + (setq steps + (append (tramp-compat-split-string + symlink-target "/") + steps))) + (t + ;; It's a file. + (setq result (cons thisstep result))))) + (when (>= numchase numchase-limit) + (tramp-error + v 'file-error + "Maximum number (%d) of symlinks exceeded" numchase-limit)) + (setq result (reverse result)) + ;; Combine list to form string. + (setq result + (if result + (mapconcat 'identity (cons "" result) "/") + "/")) + (when (and is-dir (or (string= "" result) + (not (string= (substring result -1) "/")))) + (setq result (concat result "/")))) + + (tramp-message v 4 "True name of `%s' is `%s'" localname result) + result)))) + + ;; Preserve trailing "/". + (if (string-equal (file-name-nondirectory filename) "") "/" ""))) (defun tramp-adb-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." @@ -313,13 +345,14 @@ pass to the OPERATION." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname (format "file-attributes-%s" id-format) - (tramp-adb-barf-unless-okay - v (format "%s -d -l %s" - (tramp-adb-get-ls-command v) - (tramp-shell-quote-argument localname)) "") - (with-current-buffer (tramp-get-buffer v) - (tramp-adb-sh-fix-ls-output) - (cdar (tramp-do-parse-file-attributes-with-ls v id-format))))))) + (and + (tramp-adb-send-command-and-check + v (format "%s -d -l %s" + (tramp-adb-get-ls-command v) + (tramp-shell-quote-argument localname))) + (with-current-buffer (tramp-get-buffer v) + (tramp-adb-sh-fix-ls-output) + (cdar (tramp-do-parse-file-attributes-with-ls v id-format)))))))) (defun tramp-do-parse-file-attributes-with-ls (vec &optional id-format) "Parse `file-attributes' for Tramp files using the ls(1) command." @@ -363,37 +396,47 @@ pass to the OPERATION." "Like `directory-files-and-attributes' for Tramp files." (when (file-directory-p directory) (with-parsed-tramp-file-name (expand-file-name directory) nil - (with-tramp-file-property - v localname (format "directory-files-attributes-%s-%s-%s-%s" - full match id-format nosort) - (tramp-adb-barf-unless-okay - v (format "%s -a -l %s" - (tramp-adb-get-ls-command v) - (tramp-shell-quote-argument localname)) "") - (with-current-buffer (tramp-get-buffer v) - (tramp-adb-sh-fix-ls-output) - (let ((result (tramp-do-parse-file-attributes-with-ls - v (or id-format 'integer)))) - (when full - (setq result - (mapcar - (lambda (x) - (cons (expand-file-name (car x) directory) (cdr x))) - result))) - (unless nosort - (setq result - (sort result (lambda (x y) (string< (car x) (car y)))))) - (delq nil - (mapcar (lambda (x) - (if (or (not match) (string-match match (car x))) - x)) - result)))))))) + (copy-tree + (with-tramp-file-property + v localname (format "directory-files-and-attributes-%s-%s-%s-%s" + full match id-format nosort) + (with-current-buffer (tramp-get-buffer v) + (when (tramp-adb-send-command-and-check + v (format "%s -a -l %s" + (tramp-adb-get-ls-command v) + (tramp-shell-quote-argument localname))) + ;; We insert also filename/. and filename/.., because "ls" doesn't. + (narrow-to-region (point) (point)) + (tramp-adb-send-command + v (format "%s -d -a -l %s %s" + (tramp-adb-get-ls-command v) + (tramp-shell-quote-argument + (concat (file-name-as-directory localname) ".")) + (tramp-shell-quote-argument + (concat (file-name-as-directory localname) "..")))) + (widen)) + (tramp-adb-sh-fix-ls-output) + (let ((result (tramp-do-parse-file-attributes-with-ls + v (or id-format 'integer)))) + (when full + (setq result + (mapcar + (lambda (x) + (cons (expand-file-name (car x) directory) (cdr x))) + result))) + (unless nosort + (setq result + (sort result (lambda (x y) (string< (car x) (car y)))))) + (delq nil + (mapcar (lambda (x) + (if (or (not match) (string-match match (car x))) + x)) + result))))))))) (defun tramp-adb-get-ls-command (vec) (with-tramp-connection-property vec "ls" (tramp-message vec 5 "Finding a suitable `ls' command") - (if (zerop (tramp-adb-command-exit-status - vec "ls --color=never -al /dev/null")) + (if (tramp-adb-send-command-and-check vec "ls --color=never -al /dev/null") ;; On CyanogenMod based system BusyBox is used and "ls" output ;; coloring is enabled by default. So we try to disable it ;; when possible. @@ -407,9 +450,9 @@ Convert (\"-al\") to (\"-a\" \"-l\"). Remove arguments like \"--dired\"." (split-string (apply 'concat (mapcar (lambda (s) - (replace-regexp-in-string + (tramp-compat-replace-regexp-in-string "\\(.\\)" " -\\1" - (replace-regexp-in-string "^-" "" s))) + (tramp-compat-replace-regexp-in-string "^-" "" s))) ;; FIXME: Warning about removed switches (long and non-dash). (delq nil (mapcar @@ -417,35 +460,6 @@ Convert (\"-al\") to (\"-a\" \"-l\"). Remove arguments like \"--dired\"." (and (not (string-match "\\(^--\\|^[^-]\\)" s)) s)) switches)))))) -(defun tramp-adb-handle-insert-directory - (filename switches &optional _wildcard _full-directory-p) - "Like `insert-directory' for Tramp files." - (when (stringp switches) - (setq switches (tramp-adb--gnu-switches-to-ash (split-string switches)))) - (with-parsed-tramp-file-name (file-truename filename) nil - (with-current-buffer (tramp-get-buffer v) - (let ((name (tramp-shell-quote-argument (directory-file-name localname))) - (switch-d (member "-d" switches)) - (switch-t (member "-t" switches)) - (switches (mapconcat 'identity (remove "-t" switches) " "))) - (tramp-adb-barf-unless-okay - v (format "%s %s %s" (tramp-adb-get-ls-command v) switches name) - "Cannot insert directory listing: %s" filename) - (unless switch-d - ;; We insert also filename/. and filename/.., because "ls" doesn't. - (narrow-to-region (point) (point)) - (ignore-errors - (tramp-adb-barf-unless-okay - v (format "%s -d %s %s %s" - (tramp-adb-get-ls-command v) - switches - (concat (file-name-as-directory name) ".") - (concat (file-name-as-directory name) "..")) - "Cannot insert directory listing: %s" filename)) - (widen)) - (tramp-adb-sh-fix-ls-output switch-t))) - (insert-buffer-substring (tramp-get-buffer v)))) - (defun tramp-adb-sh-fix-ls-output (&optional sort-by-time) "Insert dummy 0 in empty size columns. Androids \"ls\" command doesn't insert size column for directories: @@ -473,9 +487,7 @@ Emacs dired can't find files." (insert " " (mapconcat 'identity sorted-lines "\n "))) ;; Add final newline. (goto-char (point-max)) - (unless (= (point) (line-beginning-position)) - (insert "\n")))) - + (unless (bolp) (insert "\n")))) (defun tramp-adb-ls-output-time-less-p (a b) "Sort \"ls\" output by time, descending." @@ -484,16 +496,15 @@ Emacs dired can't find files." (setq time-a (apply 'encode-time (parse-time-string (match-string 0 a)))) (string-match tramp-adb-ls-date-regexp b) (setq time-b (apply 'encode-time (parse-time-string (match-string 0 b)))) - (tramp-time-less-p time-b time-a))) + (time-less-p time-b time-a))) (defun tramp-adb-ls-output-name-less-p (a b) "Sort \"ls\" output by name, ascending." - (let (posa posb) - (string-match dired-move-to-filename-regexp a) - (setq posa (match-end 0)) - (string-match dired-move-to-filename-regexp b) - (setq posb (match-end 0)) - (string-lessp (substring a posa) (substring b posb)))) + (if (string-match directory-listing-before-filename-regexp a) + (let ((posa (match-end 0))) + (if (string-match directory-listing-before-filename-regexp b) + (let ((posb (match-end 0))) + (string-lessp (substring a posa) (substring b posb))))))) (defun tramp-adb-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." @@ -506,7 +517,8 @@ Emacs dired can't find files." (tramp-adb-barf-unless-okay v (format "mkdir %s" (tramp-shell-quote-argument localname)) "Couldn't make directory %s" dir) - (tramp-flush-directory-property v (file-name-directory localname)))) + (tramp-flush-file-property v (file-name-directory localname)) + (tramp-flush-directory-property v localname))) (defun tramp-adb-handle-delete-directory (directory &optional recursive) "Like `delete-directory' for Tramp files." @@ -538,20 +550,22 @@ Emacs dired can't find files." (with-tramp-file-property v localname "file-name-all-completions" (save-match-data (tramp-adb-send-command - v (format "%s %s" + v (format "%s -a %s" (tramp-adb-get-ls-command v) (tramp-shell-quote-argument localname))) (mapcar (lambda (f) - (if (file-directory-p f) + (if (file-directory-p (expand-file-name f directory)) (file-name-as-directory f) f)) (with-current-buffer (tramp-get-buffer v) - (delq - nil - (mapcar - (lambda (l) (and (not (string-match "^[[:space:]]*$" l)) l)) - (split-string (buffer-string) "\n")))))))))) + (append + '("." "..") + (delq + nil + (mapcar + (lambda (l) (and (not (string-match "^[[:space:]]*$" l)) l)) + (split-string (buffer-string) "\n"))))))))))) (defun tramp-adb-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." @@ -563,11 +577,16 @@ Emacs dired can't find files." (let ((tmpfile (tramp-compat-make-temp-file filename))) (with-tramp-progress-reporter v 3 (format "Fetching %s to tmp file %s" filename tmpfile) - (when (tramp-adb-execute-adb-command v "pull" localname tmpfile) - (delete-file tmpfile) + ;; "adb pull ..." does not always return an error code. + (when (or (tramp-adb-execute-adb-command v "pull" localname tmpfile) + (not (file-exists-p tmpfile))) + (ignore-errors (delete-file tmpfile)) (tramp-error v 'file-error "Cannot make local copy of file `%s'" filename)) - (set-file-modes tmpfile (file-modes filename))) + (set-file-modes + tmpfile + (logior (or (file-modes filename) 0) + (tramp-compat-octal-to-decimal "0400")))) tmpfile))) (defun tramp-adb-handle-file-writable-p (filename) @@ -577,9 +596,8 @@ But handle the case, if the \"test\" command is not available." (with-tramp-file-property v localname "file-writable-p" (if (tramp-adb-find-test-command v) (if (file-exists-p filename) - (zerop - (tramp-adb-command-exit-status - v (format "test -w %s" (tramp-shell-quote-argument localname)))) + (tramp-adb-send-command-and-check + v (format "test -w %s" (tramp-shell-quote-argument localname))) (and (file-directory-p (file-name-directory filename)) (file-writable-p (file-name-directory filename)))) @@ -599,9 +617,6 @@ But handle the case, if the \"test\" command is not available." "Like `write-region' for Tramp files." (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil - (when append - (tramp-error - v 'file-error "Cannot append to file using Tramp (`%s')" filename)) (when (and confirm (file-exists-p filename)) (unless (y-or-n-p (format "File %s exists; overwrite anyway? " filename)) @@ -612,14 +627,21 @@ But handle the case, if the \"test\" command is not available." (tramp-flush-file-property v localname) (let* ((curbuf (current-buffer)) (tmpfile (tramp-compat-make-temp-file filename))) + (when (and append (file-exists-p filename)) + (copy-file filename tmpfile 'ok) + (set-file-modes + tmpfile + (logior (or (file-modes tmpfile) 0) + (tramp-compat-octal-to-decimal "0600")))) (tramp-run-real-handler 'write-region (list start end tmpfile append 'no-message lockname confirm)) (with-tramp-progress-reporter - v 3 (format "Moving tmp file %s to %s" tmpfile filename) + v 3 (format-message + "Moving tmp file `%s' to `%s'" tmpfile filename) (unwind-protect (when (tramp-adb-execute-adb-command v "push" tmpfile localname) - (tramp-error v 'file-error "Cannot write: `%s' filename")) + (tramp-error v 'file-error "Cannot write: `%s'" filename)) (delete-file tmpfile))) (when (or (eq visit t) (stringp visit)) @@ -633,20 +655,21 @@ But handle the case, if the \"test\" command is not available." (defun tramp-adb-handle-set-file-modes (filename mode) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil + (tramp-flush-file-property v (file-name-directory localname)) (tramp-flush-file-property v localname) - (tramp-adb-barf-unless-okay - v (format "chmod %s %s" (tramp-compat-decimal-to-octal mode) localname) - "Error while changing file's mode %s" filename))) + (tramp-adb-send-command-and-check + v (format "chmod %s %s" (tramp-compat-decimal-to-octal mode) localname)))) (defun tramp-adb-handle-set-file-times (filename &optional time) "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil + (tramp-flush-file-property v (file-name-directory localname)) (tramp-flush-file-property v localname) (let ((time (if (or (null time) (equal time '(0 0))) (current-time) time))) - (tramp-adb-command-exit-status - ;; use shell arithmetic because of Emacs integer size limit + (tramp-adb-send-command-and-check + ;; Use shell arithmetic because of Emacs integer size limit. v (format "touch -t $(( %d * 65536 + %d )) %s" (car time) (cadr time) (tramp-shell-quote-argument localname)))))) @@ -662,7 +685,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (if (file-directory-p filename) (tramp-file-name-handler 'copy-directory filename newname keep-date t) (with-tramp-progress-reporter - (tramp-dissect-file-name (if (file-remote-p filename) filename newname)) + (tramp-dissect-file-name + (if (tramp-tramp-file-p filename) filename newname)) 0 (format "Copying %s to %s" filename newname) (let ((tmpfile (file-local-copy filename))) @@ -703,32 +727,36 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setq filename (expand-file-name filename) newname (expand-file-name newname)) - (with-parsed-tramp-file-name - (if (file-remote-p filename) filename newname) nil - (with-tramp-progress-reporter - v 0 (format "Renaming %s to %s" newname filename) - - (if (and (tramp-equal-remote filename newname) - (not (file-directory-p filename))) - (progn - (when (and (not ok-if-already-exists) - (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) - ;; Short track. - (tramp-adb-barf-unless-okay - v (format - "mv %s %s" - (tramp-file-name-handler 'file-remote-p filename 'localname) - localname) - "Error renaming %s to %s" filename newname)) - - ;; Rename by copy. - (copy-file filename newname ok-if-already-exists t t) - (delete-file filename))))) + (let ((t1 (tramp-tramp-file-p filename)) + (t2 (tramp-tramp-file-p newname))) + (with-parsed-tramp-file-name (if t1 filename newname) nil + (with-tramp-progress-reporter + v 0 (format "Renaming %s to %s" filename newname) + + (if (and t1 t2 + (tramp-equal-remote filename newname) + (not (file-directory-p filename))) + (let ((l1 (tramp-file-name-handler + 'file-remote-p filename 'localname)) + (l2 (tramp-file-name-handler + 'file-remote-p newname 'localname))) + (when (and (not ok-if-already-exists) + (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-property v (file-name-directory l1)) + (tramp-flush-file-property v l1) + (tramp-flush-file-property v (file-name-directory l2)) + (tramp-flush-file-property v l2) + ;; Short track. + (tramp-adb-barf-unless-okay + v (format "mv %s %s" l1 l2) + "Error renaming %s to %s" filename newname)) + + ;; Rename by copy. + (copy-file filename newname ok-if-already-exists t t) + (delete-file filename)))))) (defun tramp-adb-handle-process-file (program &optional infile destination display &rest args) @@ -799,16 +827,18 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; directory. (condition-case nil (progn - (setq ret 0) - (tramp-adb-barf-unless-okay - v (format "(cd %s; %s)" - (tramp-shell-quote-argument localname) command) - "") - ;; We should show the output anyway. + (setq ret + (if (tramp-adb-send-command-and-check + v + (format "(cd %s; %s)" + (tramp-shell-quote-argument localname) command)) + ;; Set return status accordingly. + 0 1)) + ;; We should add the output anyway. (when outbuf (with-current-buffer outbuf (insert-buffer-substring (tramp-get-connection-buffer v))) - (when display (display-buffer outbuf)))) + (when (and display (get-buffer-window outbuf t)) (redisplay)))) ;; When the user did interrupt, we should do it also. We use ;; return code -1 as marker. (quit @@ -827,9 +857,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when tmpinput (delete-file tmpinput)) ;; `process-file-side-effects' has been introduced with GNU - ;; Emacs 23.2. If set to `nil', no remote file will be changed + ;; Emacs 23.2. If set to nil, no remote file will be changed ;; by `program'. If it doesn't exist, we assume its default - ;; value 't'. + ;; value t. (unless (and (boundp 'process-file-side-effects) (not (symbol-value 'process-file-side-effects))) (tramp-flush-directory-property v "")) @@ -874,7 +904,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when p (if (yes-or-no-p "A command is running. Kill it? ") (ignore-errors (kill-process p)) - (tramp-compat-user-error "Shell command in progress"))) + (tramp-user-error p "Shell command in progress"))) (if current-buffer-p (progn @@ -992,16 +1022,56 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (tramp-set-connection-property v "process-name" nil) (tramp-set-connection-property v "process-buffer" nil)))))) -;; Helper functions. +(defun tramp-adb-get-device (vec) + "Return full host name from VEC to be used in shell execution. +E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" + a host name \"R38273882DE\" returns \"R38273882DE\"." + ;; Sometimes this is called before there is a connection process + ;; yet. In order to work with the connection cache, we flush all + ;; unwanted entries first. + (tramp-flush-connection-property nil) + (with-tramp-connection-property (tramp-get-connection-process vec) "device" + (let* ((method (tramp-file-name-method vec)) + (host (tramp-file-name-host vec)) + (port (tramp-file-name-port vec)) + (devices (mapcar 'cadr (tramp-adb-parse-device-names nil)))) + (tramp-compat-replace-regexp-in-string + tramp-prefix-port-format ":" + (cond ((member host devices) host) + ;; This is the case when the host is connected to the default port. + ((member (format "%s%s%d" host tramp-prefix-port-format port) + devices) + (format "%s:%d" host port)) + ;; An empty host name shall be mapped as well, when there + ;; is exactly one entry in `devices'. + ((and (zerop (length host)) (= (length devices) 1)) + (car devices)) + ;; Try to connect device. + ((and tramp-adb-connect-if-not-connected + (not (zerop (length host))) + (not (tramp-adb-execute-adb-command + vec "connect" + (tramp-compat-replace-regexp-in-string + tramp-prefix-port-format ":" host)))) + ;; When new device connected, running other adb command (e.g. + ;; adb shell) immediately will fail. To get around this + ;; problem, add sleep 0.1 second here. + (sleep-for 0.1) + host) + (t (tramp-error + vec 'file-error "Could not find device %s" host))))))) (defun tramp-adb-execute-adb-command (vec &rest args) "Returns nil on success error-output on failure." - (when (> (length (tramp-file-name-host vec)) 0) - (setq args (append (list "-s" (tramp-file-name-host vec)) args))) + (when (and (> (length (tramp-file-name-host vec)) 0) + ;; The -s switch is only available for ADB device commands. + (not (member (car args) (list "connect" "disconnect")))) + (setq args (append (list "-s" (tramp-adb-get-device vec)) args))) (with-temp-buffer (prog1 (unless - (zerop (apply 'tramp-call-process tramp-adb-program nil t nil args)) + (zerop + (apply 'tramp-call-process vec tramp-adb-program nil t nil args)) (buffer-string)) (tramp-message vec 6 "%s" (buffer-string))))) @@ -1009,7 +1079,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "Checks, whether the ash has a builtin \"test\" command. This happens for Android >= 4.0." (with-tramp-connection-property vec "test" - (zerop (tramp-adb-command-exit-status vec "type test")))) + (tramp-adb-send-command-and-check vec "type test"))) ;; Connection functions @@ -1032,11 +1102,12 @@ This happens for Android >= 4.0." (while (re-search-forward "\r+$" nil t) (replace-match "" nil nil))))) -(defun tramp-adb-command-exit-status +(defun tramp-adb-send-command-and-check (vec command) - "Run COMMAND and return its exit status. -Sends `echo $?' along with the COMMAND for checking the exit status. If -COMMAND is nil, just sends `echo $?'. Returns the exit status found." + "Run COMMAND and check its exit status. +Sends `echo $?' along with the COMMAND for checking the exit +status. If COMMAND is nil, just sends `echo $?'. Returns nil if +the exit status is not equal 0, and t otherwise." (tramp-adb-send-command vec (if command (format "%s; echo tramp_exit_status $?" command) @@ -1048,14 +1119,14 @@ COMMAND is nil, just sends `echo $?'. Returns the exit status found." vec 'file-error "Couldn't find exit status of `%s'" command)) (skip-chars-forward "^ ") (prog1 - (read (current-buffer)) + (zerop (read (current-buffer))) (let (buffer-read-only) (delete-region (match-beginning 0) (point-max)))))) (defun tramp-adb-barf-unless-okay (vec command fmt &rest args) "Run COMMAND, check exit status, throw error if exit status not okay. FMT and ARGS are passed to `error'." - (unless (zerop (tramp-adb-command-exit-status vec command)) + (unless (tramp-adb-send-command-and-check vec command) (apply 'tramp-error vec 'file-error fmt args))) (defun tramp-adb-wait-for-output (proc &optional timeout) @@ -1092,11 +1163,18 @@ FMT and ARGS are passed to `error'." "Maybe open a connection VEC. Does not do anything if a connection is already open, but re-opens the connection if a previous connection has died for some reason." + (tramp-check-proper-method-and-host vec) + (let* ((buf (tramp-get-connection-buffer vec)) (p (get-buffer-process buf)) (host (tramp-file-name-host vec)) (user (tramp-file-name-user vec)) - (devices (mapcar 'cadr (tramp-adb-parse-device-names nil)))) + (device (tramp-adb-get-device vec))) + + ;; Set variables for proper tracing in `tramp-adb-parse-device-names'. + (setq tramp-current-method (tramp-file-name-method vec) + tramp-current-user (tramp-file-name-user vec) + tramp-current-host (tramp-file-name-host vec)) ;; Maybe we know already that "su" is not supported. We cannot ;; use a connection property, because we have not checked yet @@ -1108,19 +1186,13 @@ connection if a previous connection has died for some reason." (and p (processp p) (memq (process-status p) '(run open))) (save-match-data (when (and p (processp p)) (delete-process p)) - (if (not devices) - (tramp-error vec 'file-error "No device connected")) - (if (and (> (length host) 0) (not (member host devices))) + (if (zerop (length device)) (tramp-error vec 'file-error "Device %s not connected" host)) - (if (and (> (length devices) 1) (zerop (length host))) - (tramp-error - vec 'file-error - "Multiple Devices connected: No Host/Device specified")) (with-tramp-progress-reporter vec 3 "Opening adb shell connection" (let* ((coding-system-for-read 'utf-8-dos) ;is this correct? (process-connection-type tramp-process-connection-type) (args (if (> (length host) 0) - (list "-s" host "shell") + (list "-s" device "shell") (list "shell"))) (p (let ((default-directory (tramp-compat-temporary-file-directory))) @@ -1132,6 +1204,7 @@ connection if a previous connection has died for some reason." (tramp-adb-wait-for-output p 30) (unless (eq 'run (process-status p)) (tramp-error vec 'file-error "Terminated!")) + (tramp-set-connection-property p "vector" vec) (tramp-compat-set-process-query-on-exit-flag p nil) ;; Check whether the properties have been changed. If @@ -1151,17 +1224,17 @@ connection if a previous connection has died for some reason." (read (current-buffer)))))) (when (and (stringp old-getprop) (not (string-equal old-getprop new-getprop))) - (tramp-cleanup vec) (tramp-message vec 3 "Connection reset, because remote host changed from `%s' to `%s'" old-getprop new-getprop) + (tramp-cleanup-connection vec t) (tramp-adb-maybe-open-connection vec))) ;; Change user if indicated. (when user (tramp-adb-send-command vec (format "su %s" user)) - (unless (zerop (tramp-adb-command-exit-status vec nil)) + (unless (tramp-adb-send-command-and-check vec nil) (delete-process p) (tramp-set-file-property vec "" "su-command-p" nil) (tramp-error @@ -1179,5 +1252,10 @@ connection if a previous connection has died for some reason." (read (current-buffer))) ":" 'omit-nulls)))))))) +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-adb 'force))) + (provide 'tramp-adb) + ;;; tramp-adb.el ends here diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 118be597433..bfcfe158281 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -1,6 +1,6 @@ ;;; tramp-cache.el --- file information caching for Tramp -;; Copyright (C) 2000, 2005-2013 Free Software Foundation, Inc. +;; Copyright (C) 2000, 2005-2015 Free Software Foundation, Inc. ;; Author: Daniel Pittman <daniel@inanna.danann.net> ;; Michael Albinus <michael.albinus@gmx.de> @@ -66,7 +66,8 @@ Every entry has the form (REGEXP PROPERTY VALUE). The regexp matches remote file names. It can be nil. PROPERTY is a string, and VALUE the corresponding value. They are used, if there is no -matching entry for PROPERTY in `tramp-cache-data'." +matching entry for PROPERTY in `tramp-cache-data'. For more +details see the info pages." :group 'tramp :version "24.4" :type '(repeat (list (choice :tag "File Name regexp" regexp (const nil)) @@ -120,9 +121,10 @@ matching entries of `tramp-connection-properties'." (defun tramp-get-file-property (key file property default) "Get the PROPERTY of FILE from the cache context of KEY. Returns DEFAULT if not set." - ;; Unify localname. + ;; Unify localname. Remove hop from vector. (setq key (copy-sequence key)) (aset key 3 (tramp-run-real-handler 'directory-file-name (list file))) + (aset key 4 nil) (let* ((hash (tramp-get-hash-table key)) (value (when (hash-table-p hash) (gethash property hash)))) (if @@ -136,7 +138,7 @@ Returns DEFAULT if not set." (tramp-time-diff (current-time) (car value)) remote-file-name-inhibit-cache)) (and (consp remote-file-name-inhibit-cache) - (tramp-time-less-p + (time-less-p remote-file-name-inhibit-cache (car value))))) (setq value (cdr value)) (setq value default)) @@ -144,7 +146,7 @@ Returns DEFAULT if not set." (tramp-message key 8 "%s %s %s" file property value) (when (>= tramp-verbose 10) (let* ((var (intern (concat "tramp-cache-get-count-" property))) - (val (or (ignore-errors (symbol-value var)) 0))) + (val (or (and (boundp var) (symbol-value var)) 0))) (set var (1+ val)))) value)) @@ -152,59 +154,75 @@ Returns DEFAULT if not set." (defun tramp-set-file-property (key file property value) "Set the PROPERTY of FILE to VALUE, in the cache context of KEY. Returns VALUE." - ;; Unify localname. + ;; Unify localname. Remove hop from vector. (setq key (copy-sequence key)) (aset key 3 (tramp-run-real-handler 'directory-file-name (list file))) + (aset key 4 nil) (let ((hash (tramp-get-hash-table key))) ;; We put the timestamp there. (puthash property (cons (current-time) value) hash) (tramp-message key 8 "%s %s %s" file property value) (when (>= tramp-verbose 10) (let* ((var (intern (concat "tramp-cache-set-count-" property))) - (val (or (ignore-errors (symbol-value var)) 0))) + (val (or (and (boundp var) (symbol-value var)) 0))) (set var (1+ val)))) value)) ;;;###tramp-autoload (defun tramp-flush-file-property (key file) "Remove all properties of FILE in the cache context of KEY." - ;; Remove file property of symlinks. - (let ((truename (tramp-get-file-property key file "file-truename" nil))) + (let* ((file (tramp-run-real-handler + 'directory-file-name (list file))) + (truename (tramp-get-file-property key file "file-truename" nil))) + ;; Remove file properties of symlinks. (when (and (stringp truename) - (not (string-equal file truename))) - (tramp-flush-file-property key truename))) - ;; Unify localname. - (setq key (copy-sequence key)) - (aset key 3 (tramp-run-real-handler 'directory-file-name (list file))) - (tramp-message key 8 "%s" file) - (remhash key tramp-cache-data)) + (not (string-equal file (directory-file-name truename)))) + (tramp-flush-file-property key truename)) + ;; Unify localname. Remove hop from vector. + (setq key (copy-sequence key)) + (aset key 3 file) + (aset key 4 nil) + (tramp-message key 8 "%s" file) + (remhash key tramp-cache-data))) ;;;###tramp-autoload (defun tramp-flush-directory-property (key directory) "Remove all properties of DIRECTORY in the cache context of KEY. Remove also properties of all files in subdirectories." - (let ((directory (tramp-run-real-handler - 'directory-file-name (list directory)))) + (let* ((directory (tramp-run-real-handler + 'directory-file-name (list directory))) + (truename (tramp-get-file-property key directory "file-truename" nil))) + ;; Remove file properties of symlinks. + (when (and (stringp truename) + (not (string-equal directory (directory-file-name truename)))) + (tramp-flush-directory-property key truename)) (tramp-message key 8 "%s" directory) (maphash (lambda (key _value) (when (and (stringp (tramp-file-name-localname key)) - (string-match directory (tramp-file-name-localname key))) + (string-match (regexp-quote directory) + (tramp-file-name-localname key))) (remhash key tramp-cache-data))) tramp-cache-data))) ;; Reverting or killing a buffer should also flush file properties. ;; They could have been changed outside Tramp. In eshell, "ls" would ;; not show proper directory contents when a file has been copied or -;; deleted before. +;; deleted before. We must apply `save-match-data', because it would +;; corrupt other packages otherwise (reported from org). (defun tramp-flush-file-function () - "Flush all Tramp cache properties from `buffer-file-name'." - (let ((bfn (if (stringp (buffer-file-name)) - (buffer-file-name) - default-directory))) - (when (tramp-tramp-file-p bfn) - (with-parsed-tramp-file-name bfn nil - (tramp-flush-file-property v localname))))) + "Flush all Tramp cache properties from `buffer-file-name'. +This is suppressed for temporary buffers." + (save-match-data + (unless (or (null (buffer-name)) + (string-match "^\\( \\|\\*\\)" (buffer-name))) + (let ((bfn (if (stringp (buffer-file-name)) + (buffer-file-name) + default-directory)) + (tramp-verbose 0)) + (when (tramp-tramp-file-p bfn) + (with-parsed-tramp-file-name bfn nil + (tramp-flush-file-property v localname))))))) (add-hook 'before-revert-hook 'tramp-flush-file-function) (add-hook 'eshell-pre-command-hook 'tramp-flush-file-function) @@ -225,11 +243,12 @@ Remove also properties of all files in subdirectories." "Get the named PROPERTY for the connection. KEY identifies the connection, it is either a process or a vector. If the value is not set for the connection, returns DEFAULT." - ;; Unify key by removing localname from vector. Work with a copy in - ;; order to avoid side effects. + ;; Unify key by removing localname and hop from vector. Work with a + ;; copy in order to avoid side effects. (when (vectorp key) (setq key (copy-sequence key)) - (aset key 3 nil)) + (aset key 3 nil) + (aset key 4 nil)) (let* ((hash (tramp-get-hash-table key)) (value (if (hash-table-p hash) (gethash property hash default) @@ -242,11 +261,12 @@ If the value is not set for the connection, returns DEFAULT." "Set the named PROPERTY of a connection to VALUE. KEY identifies the connection, it is either a process or a vector. PROPERTY is set persistent when KEY is a vector." - ;; Unify key by removing localname from vector. Work with a copy in - ;; order to avoid side effects. + ;; Unify key by removing localname and hop from vector. Work with a + ;; copy in order to avoid side effects. (when (vectorp key) (setq key (copy-sequence key)) - (aset key 3 nil)) + (aset key 3 nil) + (aset key 4 nil)) (let ((hash (tramp-get-hash-table key))) (puthash property value hash) (setq tramp-cache-data-changed t) @@ -263,11 +283,12 @@ KEY identifies the connection, it is either a process or a vector." (defun tramp-flush-connection-property (key) "Remove all properties identified by KEY. KEY identifies the connection, it is either a process or a vector." - ;; Unify key by removing localname from vector. Work with a copy in - ;; order to avoid side effects. + ;; Unify key by removing localname and hop from vector. Work with a + ;; copy in order to avoid side effects. (when (vectorp key) (setq key (copy-sequence key)) - (aset key 3 nil)) + (aset key 3 nil) + (aset key 4 nil)) (tramp-message key 7 "%s %s" key (let ((hash (gethash key tramp-cache-data)) @@ -285,6 +306,21 @@ KEY identifies the connection, it is either a process or a vector." (let (result) (maphash (lambda (key value) + ;; Remove text properties from KEY and VALUE. + ;; `substring-no-properties' does not exist in XEmacs. + (when (functionp 'substring-no-properties) + (when (vectorp key) + (dotimes (i (length key)) + (when (stringp (aref key i)) + (aset key i + (tramp-compat-funcall + 'substring-no-properties (aref key i)))))) + (when (stringp key) + (setq key (tramp-compat-funcall 'substring-no-properties key))) + (when (stringp value) + (setq value + (tramp-compat-funcall 'substring-no-properties value)))) + ;; Dump. (let ((tmp (format "(%s %s)" (if (processp key) @@ -336,7 +372,7 @@ KEY identifies the connection, it is either a process or a vector." (remhash key cache))) cache) ;; Dump it. - (with-temp-buffer + (with-temp-file tramp-persistency-file-name (insert ";; -*- emacs-lisp -*-" ;; `time-stamp-string' might not exist in all (X)Emacs flavors. @@ -350,9 +386,7 @@ KEY identifies the connection, it is either a process or a vector." ";; Tramp connection history. Don't change this file.\n" ";; You can delete it, forcing Tramp to reapply the checks.\n\n" (with-output-to-string - (pp (read (format "(%s)" (tramp-cache-print cache)))))) - (write-region - (point-min) (point-max) tramp-persistency-file-name)))))) + (pp (read (format "(%s)" (tramp-cache-print cache))))))))))) (unless noninteractive (add-hook 'kill-emacs-hook 'tramp-dump-connection-properties)) @@ -390,6 +424,7 @@ for all methods. Resulting data are derived from connection history." (with-temp-buffer (insert-file-contents tramp-persistency-file-name) (let ((list (read (current-buffer))) + (tramp-verbose 0) element key item) (while (setq element (pop list)) (setq key (pop element)) @@ -405,7 +440,7 @@ for all methods. Resulting data are derived from connection history." (clrhash tramp-cache-data)) (error ;; File is corrupted. - (message "Tramp persistency file '%s' is corrupted: %s" + (message "Tramp persistency file `%s' is corrupted: %s" tramp-persistency-file-name (error-message-string err)) (clrhash tramp-cache-data)))) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index 937db34a346..22c139859f9 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -1,6 +1,6 @@ ;;; tramp-cmds.el --- Interactive commands for Tramp -;; Copyright (C) 2007-2013 Free Software Foundation, Inc. +;; Copyright (C) 2007-2015 Free Software Foundation, Inc. ;; Author: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes @@ -48,16 +48,15 @@ nil (mapcar (lambda (x) - (with-current-buffer x - (when (and (stringp default-directory) - (file-remote-p default-directory)) - x))) + (with-current-buffer x (when (tramp-tramp-file-p default-directory) x))) (buffer-list)))) ;;;###tramp-autoload -(defun tramp-cleanup-connection (vec) +(defun tramp-cleanup-connection (vec &optional keep-debug keep-password) "Flush all connection related objects. -This includes password cache, file cache, connection cache, buffers. +This includes password cache, file cache, connection cache, +buffers. KEEP-DEBUG non-nil preserves the debug buffer. +KEEP-PASSWORD non-nil preserves the password cache. When called interactively, a Tramp connection has to be selected." (interactive ;; When interactive, select the Tramp remote identification. @@ -79,15 +78,20 @@ When called interactively, a Tramp connection has to be selected." (completing-read "Enter Tramp connection: " connections nil t (try-completion "" connections))) - (when (and name (file-remote-p name)) - (with-parsed-tramp-file-name name nil v)))))) + (and (tramp-tramp-file-p name) (tramp-dissect-file-name name)))) + nil nil)) (if (not vec) ;; Nothing to do. (message "No Tramp connection found.") ;; Flush password cache. - (tramp-clear-passwd vec) + (unless keep-password (tramp-clear-passwd vec)) + + ;; Cleanup `tramp-current-connection'. Otherwise, we would be + ;; suppressed in the test suite. We use `keep-password' as + ;; indicator; it is not worth to add a new argument. + (when keep-password (setq tramp-current-connection nil)) ;; Flush file cache. (tramp-flush-directory-property vec "") @@ -101,7 +105,8 @@ When called interactively, a Tramp connection has to be selected." ;; Remove buffers. (dolist (buf (list (get-buffer (tramp-buffer-name vec)) - (get-buffer (tramp-debug-buffer-name vec)) + (unless keep-debug + (get-buffer (tramp-debug-buffer-name vec))) (tramp-get-connection-property vec "process-buffer" nil))) (when (bufferp buf) (kill-buffer buf))))) @@ -109,8 +114,7 @@ When called interactively, a Tramp connection has to be selected." (defun tramp-cleanup-this-connection () "Flush all connection related objects of the current buffer's connection." (interactive) - (and (stringp default-directory) - (file-remote-p default-directory) + (and (tramp-tramp-file-p default-directory) (tramp-cleanup-connection (tramp-dissect-file-name default-directory 'noexpand)))) @@ -153,8 +157,8 @@ This includes password cache, file cache, connection cache, buffers." (interactive "P") (if arg (insert tramp-version) (message tramp-version))) -;; Make the `reporter` functionality available for making bug reports about -;; the package. A most useful piece of code. +;; Make the "reporter" functionality available for making bug reports about +;; the package. A most useful piece of code. (autoload 'reporter-submit-bug-report "reporter") @@ -190,7 +194,9 @@ This includes password cache, file cache, connection cache, buffers." 'tramp-load-report-modules ; pre-hook 'tramp-append-tramp-buffers ; post-hook - (propertize "\n" 'display "\ + (tramp-compat-funcall + (if (functionp 'propertize) 'propertize 'progn) + "\n" 'display "\ Enter your bug report in this message, including as much detail as you possibly can about the problem, what you did to cause it and what the local and remote machines are. @@ -230,8 +236,11 @@ buffer in your bug report. (string-match (concat "[^" (symbol-value 'mm-7bit-chars) "]") val)) (with-current-buffer reporter-eval-buffer - (set varsym (format "(base64-decode-string \"%s\")" - (base64-encode-string val)))))) + (set + varsym + (format + "(decode-coding-string (base64-decode-string \"%s\") 'raw-text)" + (base64-encode-string (encode-coding-string val 'raw-text))))))) ;; Dump variable. (tramp-compat-funcall 'reporter-dump-variable varsym mailbuf) @@ -355,7 +364,7 @@ the debug buffer(s).") (kill-buffer nil) (switch-to-buffer curbuf) (goto-char (point-max)) - (insert (propertize "\n" 'display "\n\ + (insert (tramp-compat-funcall 'propertize "\n" 'display "\n\ This is a special notion of the `gnus/message' package. If you use another mail agent (by copying the contents of this buffer) please ensure that the buffers are attached to your email.\n\n")) diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 71703fe6ab1..c57102881bf 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -1,6 +1,6 @@ ;;; tramp-compat.el --- Tramp compatibility functions -;; Copyright (C) 2007-2013 Free Software Foundation, Inc. +;; Copyright (C) 2007-2015 Free Software Foundation, Inc. ;; Author: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes @@ -35,6 +35,11 @@ (eval-and-compile + ;; GNU Emacs 22. + (unless (fboundp 'ignore-errors) + (load "cl" 'noerror) + (load "cl-macs" 'noerror)) + ;; Some packages must be required for XEmacs, because we compile ;; with -no-autoloads. (when (featurep 'xemacs) @@ -44,7 +49,8 @@ (require 'outline) (require 'passwd) (require 'pp) - (require 'regexp-opt)) + (require 'regexp-opt) + (require 'time-date)) (require 'advice) (require 'custom) @@ -94,7 +100,7 @@ (setq byte-compile-not-obsolete-vars '(directory-sep-char))) ;; `remote-file-name-inhibit-cache' has been introduced with Emacs 24.1. - ;; Besides `t', `nil', and integer, we use also timestamps (as + ;; Besides t, nil, and integer, we use also timestamps (as ;; returned by `current-time') internally. (unless (boundp 'remote-file-name-inhibit-cache) (defvar remote-file-name-inhibit-cache nil)) @@ -116,16 +122,6 @@ ;; `tramp-handle-*' functions, because this would bypass the locking ;; mechanism. - ;; `file-remote-p' has been introduced with Emacs 22. The version - ;; of XEmacs is not a magic file name function (yet). - (unless (fboundp 'file-remote-p) - (defalias 'file-remote-p - (lambda (file &optional identification connected) - (when (tramp-tramp-file-p file) - (tramp-compat-funcall - 'tramp-file-name-handler - 'file-remote-p file identification connected))))) - ;; `process-file' does not exist in XEmacs. (unless (fboundp 'process-file) (defalias 'process-file @@ -181,12 +177,16 @@ (lambda () (ad-remove-advice 'file-expand-wildcards 'around 'tramp-advice-file-expand-wildcards) - (ad-activate 'file-expand-wildcards))))) + (ad-activate 'file-expand-wildcards)))) + + ;; `redisplay' does not exist in XEmacs. + (unless (fboundp 'redisplay) + (defalias 'redisplay 'ignore))) ;; `with-temp-message' does not exist in XEmacs. (if (fboundp 'with-temp-message) (defalias 'tramp-compat-with-temp-message 'with-temp-message) - (defmacro tramp-compat-with-temp-message (message &rest body) + (defmacro tramp-compat-with-temp-message (_message &rest body) "Display MESSAGE temporarily if non-nil while BODY is evaluated." `(progn ,@body))) @@ -313,13 +313,21 @@ Not actually used. Use `(format \"%o\" i)' instead?" "Like `copy-file' for Tramp files (compat function)." (cond (preserve-extended-attributes - (tramp-compat-funcall - 'copy-file filename newname ok-if-already-exists keep-date - preserve-uid-gid preserve-extended-attributes)) + (condition-case nil + (tramp-compat-funcall + 'copy-file filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + (wrong-number-of-arguments + (tramp-compat-copy-file + filename newname ok-if-already-exists keep-date preserve-uid-gid)))) (preserve-uid-gid - (tramp-compat-funcall - 'copy-file filename newname ok-if-already-exists keep-date - preserve-uid-gid)) + (condition-case nil + (tramp-compat-funcall + 'copy-file filename newname ok-if-already-exists keep-date + preserve-uid-gid) + (wrong-number-of-arguments + (tramp-compat-copy-file + filename newname ok-if-already-exists keep-date)))) (t (copy-file filename newname ok-if-already-exists keep-date)))) @@ -408,6 +416,13 @@ Not actually used. Use `(format \"%o\" i)' instead?" directory 'full "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*"))) (delete-directory directory)))) +;; MUST-SUFFIX doesn't exist on XEmacs. +(defun tramp-compat-load (file &optional noerror nomessage nosuffix must-suffix) + "Like `load' for Tramp files (compat function)." + (if must-suffix + (tramp-compat-funcall 'load file noerror nomessage nosuffix must-suffix) + (load file noerror nomessage nosuffix))) + ;; `number-sequence' does not exist in XEmacs. Implementation is ;; taken from Emacs 23. (defun tramp-compat-number-sequence (from &optional to inc) @@ -438,7 +453,7 @@ element is not omitted." (delete "" (split-string string pattern))) (defun tramp-compat-process-running-p (process-name) - "Returns `t' if system process PROCESS-NAME is running for `user-login-name'." + "Returns t if system process PROCESS-NAME is running for `user-login-name'." (when (stringp process-name) (cond ;; GNU Emacs 22 on w32. @@ -463,7 +478,7 @@ element is not omitted." ;; Fallback, if there is no Lisp support yet. (t (let ((default-directory - (if (file-remote-p default-directory) + (if (tramp-tramp-file-p default-directory) (tramp-compat-temporary-file-directory) default-directory)) (unix95 (getenv "UNIX95")) @@ -512,19 +527,84 @@ EOL-TYPE can be one of `dos', `unix', or `mac'." (cond ((eq eol-type 'dos) 'crlf) ((eq eol-type 'unix) 'lf) ((eq eol-type 'mac) 'cr) - (t - (error "Unknown EOL-TYPE `%s', must be %s" - eol-type - "`dos', `unix', or `mac'"))))) + (t (error + "Unknown EOL-TYPE `%s', must be `dos', `unix', or `mac'" + eol-type))))) (t (error "Can't change EOL conversion -- is MULE missing?")))) -;; `user-error' has been added to Emacs 24.3. -(defun tramp-compat-user-error (format &rest args) - "Signal a pilot error." - (apply (if (fboundp 'user-error) 'user-error 'error) format args)) +;; `replace-regexp-in-string' does not exist in XEmacs. +;; Implementation is taken from Emacs 24. +(if (fboundp 'replace-regexp-in-string) + (defalias 'tramp-compat-replace-regexp-in-string 'replace-regexp-in-string) + (defun tramp-compat-replace-regexp-in-string + (regexp rep string &optional fixedcase literal subexp start) + "Replace all matches for REGEXP with REP in STRING. + +Return a new string containing the replacements. + +Optional arguments FIXEDCASE, LITERAL and SUBEXP are like the +arguments with the same names of function `replace-match'. If START +is non-nil, start replacements at that index in STRING. + +REP is either a string used as the NEWTEXT arg of `replace-match' or a +function. If it is a function, it is called with the actual text of each +match, and its value is used as the replacement text. When REP is called, +the match data are the result of matching REGEXP against a substring +of STRING. + +To replace only the first match (if any), make REGEXP match up to \\' +and replace a sub-expression, e.g. + (replace-regexp-in-string \"\\\\(foo\\\\).*\\\\'\" \"bar\" \" foo foo\" nil nil 1) + => \" bar foo\"" + + (let ((l (length string)) + (start (or start 0)) + matches str mb me) + (save-match-data + (while (and (< start l) (string-match regexp string start)) + (setq mb (match-beginning 0) + me (match-end 0)) + ;; If we matched the empty string, make sure we advance by one char + (when (= me mb) (setq me (min l (1+ mb)))) + ;; Generate a replacement for the matched substring. + ;; Operate only on the substring to minimize string consing. + ;; Set up match data for the substring for replacement; + ;; presumably this is likely to be faster than munging the + ;; match data directly in Lisp. + (string-match regexp (setq str (substring string mb me))) + (setq matches + (cons (replace-match (if (stringp rep) + rep + (funcall rep (match-string 0 str))) + fixedcase literal str subexp) + (cons (substring string start mb) ; unmatched prefix + matches))) + (setq start me)) + ;; Reconstruct a string from the pieces. + (setq matches (cons (substring string start l) matches)) ; leftover + (apply #'concat (nreverse matches)))))) + +;; `default-toplevel-value' has been declared in Emacs 24. +(unless (fboundp 'default-toplevel-value) + (defalias 'default-toplevel-value 'symbol-value)) + +;; `format-message' is new in Emacs 25, and does not exist in XEmacs. +(unless (fboundp 'format-message) + (defalias 'format-message 'format)) + +;; `delete-dups' does not exist in XEmacs 21.4. +(if (fboundp 'delete-dups) + (defalias 'tramp-compat-delete-dups 'delete-dups) + (defun tramp-compat-delete-dups (list) + "Destructively remove `equal' duplicates from LIST. +Store the result in LIST and return it. LIST must be a proper list. +Of several `equal' occurrences of an element in LIST, the first +one is kept." + (cl-delete-duplicates list '(:test equal :from-end) nil))) (add-hook 'tramp-unload-hook (lambda () + (unload-feature 'tramp-loaddefs 'force) (unload-feature 'tramp-compat 'force))) (provide 'tramp-compat) diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el index 9e1be06a2b1..23646a05fdf 100644 --- a/lisp/net/tramp-ftp.el +++ b/lisp/net/tramp-ftp.el @@ -1,6 +1,6 @@ ;;; tramp-ftp.el --- Tramp convenience functions for Ange-FTP -;; Copyright (C) 2002-2013 Free Software Foundation, Inc. +;; Copyright (C) 2002-2015 Free Software Foundation, Inc. ;; Author: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes @@ -120,17 +120,6 @@ present for backward compatibility." tramp-ftp-method '((tramp-parse-netrc "~/.netrc")))) -;; If there is URL syntax, `substitute-in-file-name' needs special -;; handling. -(put 'substitute-in-file-name 'ange-ftp 'tramp-handle-substitute-in-file-name) -(add-hook 'tramp-ftp-unload-hook - (lambda () - (setplist 'substitute-in-file-name - (delete 'ange-ftp - (delete 'tramp-handle-substitute-in-file-name - (symbol-plist - 'substitute-in-file-name)))))) - ;;;###tramp-autoload (defun tramp-ftp-file-name-handler (operation &rest args) "Invoke the Ange-FTP handler for OPERATION. @@ -172,7 +161,7 @@ pass to the OPERATION." ;; We must copy it locally first, because there is no place in ;; ange-ftp for correct handling. ((and (memq operation '(copy-file rename-file)) - (file-remote-p (cadr args)) + (tramp-tramp-file-p (cadr args)) (not (tramp-ftp-file-name-p (cadr args)))) (let* ((filename (car args)) (newname (cadr args)) @@ -189,12 +178,7 @@ pass to the OPERATION." (ignore-errors (delete-file tmpfile))))) ;; Normally, the handlers must be discarded. - ;; `inhibit-file-name-handlers' isn't sufficient, because the - ;; local file name could be in Tramp syntax as well (for - ;; example, returning VMS file names like "/DISK$CAM:/AAA"). - ;; That's why we set also `tramp-mode' to nil. - (t (let* (;(tramp-mode nil) - (inhibit-file-name-handlers + (t (let* ((inhibit-file-name-handlers (list 'tramp-file-name-handler 'tramp-completion-file-name-handler (and (eq inhibit-file-name-operation operation) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index f70074ba6e9..b93c4cf57a5 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -1,6 +1,6 @@ ;;; tramp-gvfs.el --- Tramp access functions for GVFS daemon -;; Copyright (C) 2009-2013 Free Software Foundation, Inc. +;; Copyright (C) 2009-2015 Free Software Foundation, Inc. ;; Author: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes @@ -47,16 +47,16 @@ ;; discovered during development time, is given in respective ;; comments. -;; The customer option `tramp-gvfs-methods' contains the list of -;; supported connection methods. Per default, these are "dav", -;; "davs", "obex" and "synce". Note that with "obex" it might be -;; necessary to pair with the other bluetooth device, if it hasn't +;; The custom option `tramp-gvfs-methods' contains the list of +;; supported connection methods. Per default, these are "afp", "dav", +;; "davs", "obex", "sftp" and "synce". Note that with "obex" it might +;; be necessary to pair with the other bluetooth device, if it hasn't ;; been done already. There might be also some few seconds delay in ;; discovering available bluetooth devices. -;; Other possible connection methods are "ftp", "sftp" and "smb". -;; When one of these methods is added to the list, the remote access -;; for that method is performed via GVFS instead of the native Tramp +;; Other possible connection methods are "ftp" and "smb". When one of +;; these methods is added to the list, the remote access for that +;; method is performed via GVFS instead of the native Tramp ;; implementation. ;; GVFS offers even more connection methods. The complete list of @@ -78,10 +78,10 @@ ;; For hostname completion, information is retrieved either from the ;; bluez daemon (for the "obex" method), the hal daemon (for the -;; "synce" method), or from the zeroconf daemon (for the "dav", +;; "synce" method), or from the zeroconf daemon (for the "afp", "dav", ;; "davs", and "sftp" methods). The zeroconf daemon is pre-configured ;; to discover services in the "local" domain. If another domain -;; shall be used for discovering services, the customer option +;; shall be used for discovering services, the custom option ;; `tramp-gvfs-zeroconf-domain' can be set accordingly. ;; Restrictions: @@ -108,14 +108,14 @@ (eval-when-compile (require 'cl) (require 'custom)) -(defvar ls-lisp-use-insert-directory-program) ;;;###tramp-autoload -(defcustom tramp-gvfs-methods '("dav" "davs" "obex" "synce") +(defcustom tramp-gvfs-methods '("afp" "dav" "davs" "obex" "sftp" "synce") "List of methods for remote files, accessed with GVFS." :group 'tramp - :version "23.2" - :type '(repeat (choice (const "dav") + :version "25.1" + :type '(repeat (choice (const "afp") + (const "dav") (const "davs") (const "ftp") (const "obex") @@ -128,6 +128,7 @@ ;;;###tramp-autoload (add-to-list 'tramp-default-user-alist '("\\`synce\\'" nil nil)) +;;;###tramp-autoload (defcustom tramp-gvfs-zeroconf-domain "local" "Zeroconf domain to be used for discovering services, like host names." :group 'tramp @@ -153,6 +154,7 @@ (defconst tramp-gvfs-enabled (ignore-errors (and (featurep 'dbusbind) + (tramp-compat-funcall 'dbus-get-unique-name :system) (tramp-compat-funcall 'dbus-get-unique-name :session) (or (tramp-compat-process-running-p "gvfs-fuse-daemon") (tramp-compat-process-running-p "gvfsd-fuse")))) @@ -167,9 +169,10 @@ ;; Introspection data exist since GVFS 1.14. If there are no such ;; data, we expect an earlier interface. (defconst tramp-gvfs-methods-mounttracker - (dbus-introspect-get-method-names - :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker - tramp-gvfs-interface-mounttracker) + (and tramp-gvfs-enabled + (dbus-introspect-get-method-names + :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker + tramp-gvfs-interface-mounttracker)) "The list of supported methods of the mount tracking interface.") (defconst tramp-gvfs-listmounts @@ -187,9 +190,10 @@ It has been changed in GVFS 1.14.") It has been changed in GVFS 1.14.") (defconst tramp-gvfs-mountlocation-signature - (dbus-introspect-get-signature - :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker - tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation) + (and tramp-gvfs-enabled + (dbus-introspect-get-signature + :session tramp-gvfs-service-daemon tramp-gvfs-path-mounttracker + tramp-gvfs-interface-mounttracker tramp-gvfs-mountlocation)) "The D-Bus signature of the \"mountLocation\" method. It has been changed in GVFS 1.14.") @@ -228,7 +232,8 @@ It has been changed in GVFS 1.14.") ;; ARRAY BYTE mount_prefix ;; ARRAY ;; STRUCT mount_spec_item -;; STRING key (server, share, type, user, host, port) +;; STRING key (type, user, domain, host, server, +;; share, volume, port, ssl) ;; ARRAY BYTE value ;; ARRAY BYTE default_location Since GVFS 1.5 only !!! @@ -372,6 +377,7 @@ It has been changed in GVFS 1.14.") ;; </signal> ;; </interface> +;;;###tramp-autoload (defcustom tramp-bluez-discover-devices-timeout 60 "Defines seconds since last bluetooth device discovery before rescanning. A value of 0 would require an immediate discovery during hostname @@ -439,6 +445,7 @@ Every entry is a list (NAME ADDRESS).") (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) (file-notify-add-watch . tramp-gvfs-handle-file-notify-add-watch) (file-notify-rm-watch . tramp-handle-file-notify-rm-watch) + (file-notify-valid-p . tramp-handle-file-notify-valid-p) (file-ownership-preserved-p . ignore) (file-readable-p . tramp-gvfs-handle-file-readable-p) (file-regular-p . tramp-handle-file-regular-p) @@ -450,13 +457,13 @@ Every entry is a list (NAME ADDRESS).") (find-backup-file-name . tramp-handle-find-backup-file-name) ;; `find-file-noselect' performed by default handler. ;; `get-file-buffer' performed by default handler. - (insert-directory . tramp-gvfs-handle-insert-directory) - (insert-file-contents . tramp-gvfs-handle-insert-file-contents) + (insert-directory . tramp-handle-insert-directory) + (insert-file-contents . tramp-handle-insert-file-contents) (load . tramp-handle-load) - ;; `make-auto-save-file-name' performed by default handler. + (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-gvfs-handle-make-directory) (make-directory-internal . ignore) - (make-symbolic-link . ignore) + (make-symbolic-link . tramp-handle-make-symbolic-link) (process-file . ignore) (rename-file . tramp-gvfs-handle-rename-file) (set-file-acl . ignore) @@ -490,7 +497,7 @@ Operations not mentioned here will be handled by the default Emacs primitives.") First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." (unless tramp-gvfs-enabled - (tramp-compat-user-error "Package `tramp-gvfs' not supported")) + (tramp-user-error nil "Package `tramp-gvfs' not supported")) (let ((fn (assoc operation tramp-gvfs-file-name-handler-alist))) (if fn (save-match-data (apply (cdr fn) args)) @@ -578,58 +585,127 @@ is no information where to trace the message.") ;; File name primitives. +(defun tramp-gvfs-do-copy-or-rename-file + (op filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + "Copy or rename a remote file. +OP must be `copy' or `rename' and indicates the operation to perform. +FILENAME specifies the file to copy or rename, NEWNAME is the name of +the new file (for copy) or the new name of the file (for rename). +OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already. +KEEP-DATE means to make sure that NEWNAME has the same timestamp +as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep +the uid and gid if both files are on the same host. +PRESERVE-EXTENDED-ATTRIBUTES is ignored. + +This function is invoked by `tramp-gvfs-handle-copy-file' and +`tramp-gvfs-handle-rename-file'. It is an error if OP is neither +of `copy' and `rename'. FILENAME and NEWNAME must be absolute +file names." + (unless (memq op '(copy rename)) + (error "Unknown operation `%s', must be `copy' or `rename'" op)) + + (let ((t1 (tramp-tramp-file-p filename)) + (t2 (tramp-tramp-file-p newname)) + (equal-remote (tramp-equal-remote filename newname)) + (file-operation (intern (format "%s-file" op))) + (gvfs-operation (if (eq op 'copy) "gvfs-copy" "gvfs-move")) + (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) + + (with-parsed-tramp-file-name (if t1 filename newname) nil + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error + v 'file-already-exists "File %s already exists" newname)) + + (if (or (and equal-remote + (tramp-get-connection-property v "direct-copy-failed" nil)) + (and t1 (not (tramp-gvfs-file-name-p filename))) + (and t2 (not (tramp-gvfs-file-name-p newname)))) + + ;; We cannot copy or rename directly. + (let ((tmpfile (tramp-compat-make-temp-file filename))) + (cond + (preserve-extended-attributes + (tramp-compat-funcall + file-operation + filename tmpfile t keep-date preserve-uid-gid + preserve-extended-attributes)) + (preserve-uid-gid + (tramp-compat-funcall + file-operation filename tmpfile t keep-date preserve-uid-gid)) + (t + (tramp-compat-funcall + file-operation filename tmpfile t keep-date))) + (rename-file tmpfile newname ok-if-already-exists)) + + ;; Direct action. + (with-tramp-progress-reporter + v 0 (format "%s %s to %s" msg-operation filename newname) + (unless + (apply + 'tramp-gvfs-send-command v gvfs-operation + (append + (and (eq op 'copy) (or keep-date preserve-uid-gid) + (list "--preserve")) + (list + (tramp-gvfs-url-file-name filename) + (tramp-gvfs-url-file-name newname)))) + + (if (or (not equal-remote) + (and equal-remote + (tramp-get-connection-property + v "direct-copy-failed" nil))) + ;; Propagate the error. + (with-current-buffer (tramp-get-connection-buffer v) + (goto-char (point-min)) + (tramp-error-with-buffer + nil v 'file-error + "%s failed, see buffer `%s' for details." + msg-operation (buffer-name))) + + ;; Some WebDAV server, like the one from QNAP, do not + ;; support direct copy/move. Try a fallback. + (tramp-set-connection-property v "direct-copy-failed" t) + (tramp-gvfs-do-copy-or-rename-file + op filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes)))) + + (when (and t1 (eq op 'rename)) + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-property v (file-name-directory localname)) + (tramp-flush-file-property v localname))) + + (when t2 + (with-parsed-tramp-file-name newname nil + (tramp-flush-file-property v (file-name-directory localname)) + (tramp-flush-file-property v localname))))))) + (defun tramp-gvfs-handle-copy-file (filename newname &optional ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes) "Like `copy-file' for Tramp files." - (with-parsed-tramp-file-name - (if (tramp-tramp-file-p filename) filename newname) nil - - (when (and (not ok-if-already-exists) (file-exists-p newname)) - (tramp-error - v 'file-already-exists "File %s already exists" newname)) - - (if (or (and (tramp-tramp-file-p filename) - (not (tramp-gvfs-file-name-p filename))) - (and (tramp-tramp-file-p newname) - (not (tramp-gvfs-file-name-p newname)))) - - ;; We cannot copy directly. - (let ((tmpfile (tramp-compat-make-temp-file filename))) - (cond - (preserve-extended-attributes - (copy-file - filename tmpfile t keep-date preserve-uid-gid - preserve-extended-attributes)) - (preserve-uid-gid - (copy-file filename tmpfile t keep-date preserve-uid-gid)) - (t - (copy-file filename tmpfile t keep-date))) - (rename-file tmpfile newname ok-if-already-exists)) - - ;; Direct copy. - (with-tramp-progress-reporter - v 0 (format "Copying %s to %s" filename newname) - (unless - (let ((args - (append (if (or keep-date preserve-uid-gid) - (list "--preserve") - nil) - (list - (tramp-gvfs-url-file-name filename) - (tramp-gvfs-url-file-name newname))))) - (apply 'tramp-gvfs-send-command v "gvfs-copy" args)) - ;; Propagate the error. - (with-current-buffer (tramp-get-connection-buffer v) - (goto-char (point-min)) - (tramp-error-with-buffer - nil v 'file-error - "Copying failed, see buffer `%s' for details." (buffer-name))))) - - (when (file-remote-p newname) - (with-parsed-tramp-file-name newname nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname)))))) + (setq filename (expand-file-name filename)) + (setq newname (expand-file-name newname)) + (cond + ;; At least one file a Tramp file? + ((or (tramp-tramp-file-p filename) + (tramp-tramp-file-p newname)) + (tramp-gvfs-do-copy-or-rename-file + 'copy filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes)) + ;; Compat section. + (preserve-extended-attributes + (tramp-run-real-handler + 'copy-file + (list filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes))) + (preserve-uid-gid + (tramp-run-real-handler + 'copy-file + (list filename newname ok-if-already-exists keep-date preserve-uid-gid))) + (t + (tramp-run-real-handler + 'copy-file (list filename newname ok-if-already-exists keep-date))))) (defun tramp-gvfs-handle-delete-directory (directory &optional recursive trash) "Like `delete-directory' for Tramp files." @@ -657,7 +733,7 @@ is no information where to trace the message.") "Like `delete-file' for Tramp files." (with-parsed-tramp-file-name filename nil (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) + (tramp-flush-file-property v localname) (unless (tramp-gvfs-send-command v (if (and trash delete-by-moving-to-trash) "gvfs-trash" "gvfs-rm") @@ -696,7 +772,7 @@ is no information where to trace the message.") (unless (tramp-run-real-handler 'file-name-absolute-p (list localname)) (setq localname (concat "/" localname))) ;; We do not pass "/..". - (if (string-equal "smb" method) + (if (string-match "^\\(afp\\|smb\\)$" method) (when (string-match "^/[^/]+\\(/\\.\\./?\\)" localname) (setq localname (replace-match "/" t t localname 1))) (when (string-match "^/\\.\\./?" localname) @@ -714,123 +790,120 @@ is no information where to trace the message.") (defun tramp-gvfs-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." (unless id-format (setq id-format 'integer)) - ;; Don't modify `last-coding-system-used' by accident. - (let ((last-coding-system-used last-coding-system-used) - dirp res-symlink-target res-numlinks res-uid res-gid res-access - res-mod res-change res-size res-filemodes res-inode res-device) - (with-parsed-tramp-file-name filename nil - (with-tramp-file-property - v localname (format "file-attributes-%s" id-format) - (tramp-message v 5 "file attributes: %s" localname) - (tramp-gvfs-send-command - v "gvfs-info" (tramp-gvfs-url-file-name filename)) - ;; Parse output ... - (with-current-buffer (tramp-get-connection-buffer v) - (goto-char (point-min)) - (when (re-search-forward "attributes:" nil t) - ;; ... directory or symlink - (goto-char (point-min)) - (setq dirp (if (re-search-forward "type:\\s-+directory" nil t) t)) - (goto-char (point-min)) - (setq res-symlink-target - (if (re-search-forward - "standard::symlink-target:\\s-+\\(\\S-+\\)" nil t) - (match-string 1))) - ;; ... number links - (goto-char (point-min)) - (setq res-numlinks - (if (re-search-forward "unix::nlink:\\s-+\\([0-9]+\\)" nil t) - (string-to-number (match-string 1)) 0)) - ;; ... uid and gid - (goto-char (point-min)) - (setq res-uid - (or (if (eq id-format 'integer) - (if (re-search-forward - "unix::uid:\\s-+\\([0-9]+\\)" nil t) - (string-to-number (match-string 1))) - (if (re-search-forward - "owner::user:\\s-+\\(\\S-+\\)" nil t) - (match-string 1))) - (tramp-get-local-uid id-format))) - (setq res-gid - (or (if (eq id-format 'integer) - (if (re-search-forward - "unix::gid:\\s-+\\([0-9]+\\)" nil t) - (string-to-number (match-string 1))) - (if (re-search-forward - "owner::group:\\s-+\\(\\S-+\\)" nil t) - (match-string 1))) - (tramp-get-local-gid id-format))) - ;; ... last access, modification and change time - (goto-char (point-min)) - (setq res-access - (if (re-search-forward - "time::access:\\s-+\\([0-9]+\\)" nil t) - (seconds-to-time (string-to-number (match-string 1))) - '(0 0))) - (goto-char (point-min)) - (setq res-mod - (if (re-search-forward - "time::modified:\\s-+\\([0-9]+\\)" nil t) - (seconds-to-time (string-to-number (match-string 1))) - '(0 0))) - (goto-char (point-min)) - (setq res-change - (if (re-search-forward - "time::changed:\\s-+\\([0-9]+\\)" nil t) - (seconds-to-time (string-to-number (match-string 1))) - '(0 0))) - ;; ... size - (goto-char (point-min)) - (setq res-size - (if (re-search-forward - "standard::size:\\s-+\\([0-9]+\\)" nil t) - (string-to-number (match-string 1)) 0)) - ;; ... file mode flags - (goto-char (point-min)) - (setq res-filemodes - (if (re-search-forward "unix::mode:\\s-+\\([0-9]+\\)" nil t) - (tramp-file-mode-from-int (match-string 1)) - (if dirp "drwx------" "-rwx------"))) - ;; ... inode and device - (goto-char (point-min)) - (setq res-inode - (if (re-search-forward "unix::inode:\\s-+\\([0-9]+\\)" nil t) - (string-to-number (match-string 1)) - (tramp-get-inode v))) + (ignore-errors + ;; Don't modify `last-coding-system-used' by accident. + (let ((last-coding-system-used last-coding-system-used) + (process-environment (cons "LC_MESSAGES=C" process-environment)) + dirp res-symlink-target res-numlinks res-uid res-gid res-access + res-mod res-change res-size res-filemodes res-inode res-device) + (with-parsed-tramp-file-name filename nil + (with-tramp-file-property + v localname (format "file-attributes-%s" id-format) + (tramp-message v 5 "file attributes: %s" localname) + (tramp-gvfs-send-command + v "gvfs-info" (tramp-gvfs-url-file-name filename)) + ;; Parse output ... + (with-current-buffer (tramp-get-connection-buffer v) (goto-char (point-min)) - (setq res-device - (if (re-search-forward "unix::device:\\s-+\\([0-9]+\\)" nil t) - (string-to-number (match-string 1)) - (tramp-get-device v))) - - ;; Return data gathered. - (list - ;; 0. t for directory, string (name linked to) for - ;; symbolic link, or nil. - (or dirp res-symlink-target) - ;; 1. Number of links to file. - res-numlinks - ;; 2. File uid. - res-uid - ;; 3. File gid. - res-gid - ;; 4. Last access time, as a list of integers. - ;; 5. Last modification time, likewise. - ;; 6. Last status change time, likewise. - res-access res-mod res-change - ;; 7. Size in bytes (-1, if number is out of range). - res-size - ;; 8. File modes. - res-filemodes - ;; 9. t if file's gid would change if file were deleted - ;; and recreated. - nil - ;; 10. Inode number. - res-inode - ;; 11. Device number. - res-device - ))))))) + (when (re-search-forward "attributes:" nil t) + ;; ... directory or symlink + (goto-char (point-min)) + (setq dirp (if (re-search-forward "type: directory" nil t) t)) + (goto-char (point-min)) + (setq res-symlink-target + (if (re-search-forward + "standard::symlink-target: \\(.+\\)$" nil t) + (match-string 1))) + ;; ... number links + (goto-char (point-min)) + (setq res-numlinks + (if (re-search-forward "unix::nlink: \\([0-9]+\\)" nil t) + (string-to-number (match-string 1)) 0)) + ;; ... uid and gid + (goto-char (point-min)) + (setq res-uid + (if (eq id-format 'integer) + (if (re-search-forward "unix::uid: \\([0-9]+\\)" nil t) + (string-to-number (match-string 1)) + -1) + (if (re-search-forward "owner::user: \\(.+\\)$" nil t) + (match-string 1) + "UNKNOWN"))) + (setq res-gid + (if (eq id-format 'integer) + (if (re-search-forward "unix::gid: \\([0-9]+\\)" nil t) + (string-to-number (match-string 1)) + -1) + (if (re-search-forward "owner::group: \\(.+\\)$" nil t) + (match-string 1) + "UNKNOWN"))) + ;; ... last access, modification and change time + (goto-char (point-min)) + (setq res-access + (if (re-search-forward "time::access: \\([0-9]+\\)" nil t) + (seconds-to-time (string-to-number (match-string 1))) + '(0 0))) + (goto-char (point-min)) + (setq res-mod + (if (re-search-forward "time::modified: \\([0-9]+\\)" nil t) + (seconds-to-time (string-to-number (match-string 1))) + '(0 0))) + (goto-char (point-min)) + (setq res-change + (if (re-search-forward "time::changed: \\([0-9]+\\)" nil t) + (seconds-to-time (string-to-number (match-string 1))) + '(0 0))) + ;; ... size + (goto-char (point-min)) + (setq res-size + (if (re-search-forward "standard::size: \\([0-9]+\\)" nil t) + (string-to-number (match-string 1)) 0)) + ;; ... file mode flags + (goto-char (point-min)) + (setq res-filemodes + (if (re-search-forward "unix::mode: \\([0-9]+\\)" nil t) + (tramp-file-mode-from-int + (string-to-number (match-string 1))) + (if dirp "drwx------" "-rwx------"))) + ;; ... inode and device + (goto-char (point-min)) + (setq res-inode + (if (re-search-forward "unix::inode: \\([0-9]+\\)" nil t) + (string-to-number (match-string 1)) + (tramp-get-inode v))) + (goto-char (point-min)) + (setq res-device + (if (re-search-forward "unix::device: \\([0-9]+\\)" nil t) + (string-to-number (match-string 1)) + (tramp-get-device v))) + + ;; Return data gathered. + (list + ;; 0. t for directory, string (name linked to) for + ;; symbolic link, or nil. + (or dirp res-symlink-target) + ;; 1. Number of links to file. + res-numlinks + ;; 2. File uid. + res-uid + ;; 3. File gid. + res-gid + ;; 4. Last access time, as a list of integers. + ;; 5. Last modification time, likewise. + ;; 6. Last status change time, likewise. + res-access res-mod res-change + ;; 7. Size in bytes (-1, if number is out of range). + res-size + ;; 8. File modes. + res-filemodes + ;; 9. t if file's gid would change if file were deleted + ;; and recreated. + nil + ;; 10. Inode number. + res-inode + ;; 11. Device number. + res-device + )))))))) (defun tramp-gvfs-handle-file-directory-p (filename) "Like `file-directory-p' for Tramp files." @@ -895,7 +968,7 @@ is no information where to trace the message.") entry) ;; Get a list of directories and files. (tramp-gvfs-send-command - v "gvfs-ls" (tramp-gvfs-url-file-name directory)) + v "gvfs-ls" "-h" (tramp-gvfs-url-file-name directory)) ;; Now grab the output. (with-temp-buffer @@ -924,24 +997,48 @@ is no information where to trace the message.") v (concat localname filename) "file-name-all-completions" result)))))))) -(defun tramp-gvfs-handle-file-notify-add-watch (file-name _flags _callback) +(defun tramp-gvfs-handle-file-notify-add-watch (file-name flags _callback) "Like `file-notify-add-watch' for Tramp files." (setq file-name (expand-file-name file-name)) (with-parsed-tramp-file-name file-name nil - (let ((p (start-process - "gvfs-monitor-file" (generate-new-buffer " *gvfs-monitor-file*") - "gvfs-monitor-file" (tramp-gvfs-url-file-name file-name)))) + ;; We cannot watch directories, because `gvfs-monitor-dir' is not + ;; supported for gvfs-mounted directories. + (when (file-directory-p file-name) + (tramp-error + v 'file-notify-error "Monitoring not supported for `%s'" file-name)) + (let* ((default-directory (file-name-directory file-name)) + (events + (cond + ((and (memq 'change flags) (memq 'attribute-change flags)) + '(created changed changes-done-hint moved deleted + attribute-changed)) + ((memq 'change flags) + '(created changed changes-done-hint moved deleted)) + ((memq 'attribute-change flags) '(attribute-changed)))) + (p (start-process + "gvfs-monitor-file" (generate-new-buffer " *gvfs-monitor-file*") + "gvfs-monitor-file" (tramp-gvfs-url-file-name file-name)))) (if (not (processp p)) (tramp-error - v 'file-notify-error "gvfs-monitor-file failed to start") + v 'file-notify-error "Monitoring not supported for `%s'" file-name) + (tramp-message + v 6 "Run `%s', %S" (mapconcat 'identity (process-command p) " ") p) + (tramp-set-connection-property p "vector" v) + (tramp-compat-process-put p 'events events) + (tramp-compat-process-put p 'watch-name localname) (tramp-compat-set-process-query-on-exit-flag p nil) - (set-process-filter p 'tramp-gvfs-file-gvfs-monitor-file-process-filter) - (with-current-buffer (process-buffer p) - (setq default-directory (file-name-directory file-name))) + (set-process-filter p 'tramp-gvfs-monitor-file-process-filter) + ;; There might be an error if the monitor is not supported. + ;; Give the filter a chance to read the output. + (tramp-accept-process-output p 1) + (unless (memq (process-status p) '(run open)) + (tramp-error + v 'file-notify-error "Monitoring not supported for `%s'" file-name)) p)))) -(defun tramp-gvfs-file-gvfs-monitor-file-process-filter (proc string) - "Read output from \"gvfs-monitor-file\" and add corresponding file-notify events." +(defun tramp-gvfs-monitor-file-process-filter (proc string) + "Read output from \"gvfs-monitor-file\" and add corresponding \ +file-notify events." (let* ((rest-string (tramp-compat-process-get proc 'rest-string)) (dd (with-current-buffer (process-buffer proc) default-directory)) (ddu (regexp-quote (tramp-gvfs-url-file-name dd)))) @@ -950,8 +1047,10 @@ is no information where to trace the message.") (tramp-message proc 6 "%S\n%s" proc string) (setq string (concat rest-string string) ;; Attribute change is returned in unused wording. - string (replace-regexp-in-string + string (tramp-compat-replace-regexp-in-string "ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string)) + (when (string-match "Monitoring not supported" string) + (delete-process proc)) (while (string-match (concat "^[\n\r]*" @@ -959,10 +1058,10 @@ is no information where to trace the message.") "File = \\([^\n\r]+\\)[\n\r]+" "Event = \\([^[:blank:]]+\\)[\n\r]+") string) - (let ((action (intern-soft - (replace-regexp-in-string - "_" "-" (downcase (match-string 2 string))))) - (file (match-string 1 string))) + (let ((file (match-string 1 string)) + (action (intern-soft + (tramp-compat-replace-regexp-in-string + "_" "-" (downcase (match-string 2 string)))))) (setq string (replace-match "" nil nil string)) ;; File names are returned as URL paths. We must convert them. (when (string-match ddu file) @@ -998,103 +1097,40 @@ is no information where to trace the message.") (and (file-directory-p (file-name-directory filename)) (file-writable-p (file-name-directory filename))))))) -(defun tramp-gvfs-handle-insert-directory - (filename switches &optional wildcard full-directory-p) - "Like `insert-directory' for Tramp files." - ;; gvfs-* output is hard to parse. So we let `ls-lisp' do the job. - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-tramp-progress-reporter v 0 (format "Opening directory %s" filename) - (require 'ls-lisp) - (let (ls-lisp-use-insert-directory-program) - (tramp-run-real-handler - 'insert-directory - (list filename switches wildcard full-directory-p)))))) - -(defun tramp-gvfs-handle-insert-file-contents - (filename &optional visit beg end replace) - "Like `insert-file-contents' for Tramp files." - (barf-if-buffer-read-only) - (setq filename (expand-file-name filename)) - (let (tmpfile result) - (unwind-protect - (if (not (file-exists-p filename)) - ;; We don't raise a Tramp error, because it might be - ;; suppressed, like in `find-file-noselect-1'. - (signal 'file-error (list "File not found on remote host" filename)) - - (setq tmpfile (file-local-copy filename) - result (insert-file-contents tmpfile visit beg end replace))) - ;; Save exit. - (when visit - (setq buffer-file-name filename) - (setq buffer-read-only (not (file-writable-p filename))) - (set-visited-file-modtime) - (set-buffer-modified-p nil)) - (when (stringp tmpfile) - (delete-file tmpfile))) - - ;; Result. - (list filename (cadr result)))) - (defun tramp-gvfs-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." + (setq dir (directory-file-name (expand-file-name dir))) (with-parsed-tramp-file-name dir nil - (unless - (apply - 'tramp-gvfs-send-command v "gvfs-mkdir" - (if parents - (list "-p" (tramp-gvfs-url-file-name dir)) - (list (tramp-gvfs-url-file-name dir)))) - ;; Propagate the error. - (tramp-error v 'file-error "Couldn't make directory %s" dir)))) + (tramp-flush-file-property v (file-name-directory localname)) + (tramp-flush-directory-property v localname) + (save-match-data + (let ((ldir (file-name-directory dir))) + ;; Make missing directory parts. "gvfs-mkdir -p ..." does not + ;; work robust. + (when (and parents (not (file-directory-p ldir))) + (make-directory ldir parents)) + ;; Just do it. + (unless (tramp-gvfs-send-command + v "gvfs-mkdir" (tramp-gvfs-url-file-name dir)) + (tramp-error v 'file-error "Couldn't make directory %s" dir)))))) (defun tramp-gvfs-handle-rename-file (filename newname &optional ok-if-already-exists) "Like `rename-file' for Tramp files." - (with-parsed-tramp-file-name - (if (tramp-tramp-file-p filename) filename newname) nil - - (when (and (not ok-if-already-exists) (file-exists-p newname)) - (tramp-error - v 'file-already-exists "File %s already exists" newname)) - - (if (or (and (tramp-tramp-file-p filename) - (not (tramp-gvfs-file-name-p filename))) - (and (tramp-tramp-file-p newname) - (not (tramp-gvfs-file-name-p newname)))) - - ;; We cannot move directly. - (let ((tmpfile (tramp-compat-make-temp-file filename))) - (rename-file filename tmpfile t) - (rename-file tmpfile newname ok-if-already-exists)) - - ;; Direct move. - (with-tramp-progress-reporter - v 0 (format "Renaming %s to %s" filename newname) - (unless - (tramp-gvfs-send-command - v "gvfs-move" - (tramp-gvfs-url-file-name filename) - (tramp-gvfs-url-file-name newname)) - ;; Propagate the error. - (with-current-buffer (tramp-get-buffer v) - (goto-char (point-min)) - (tramp-error-with-buffer - nil v 'file-error - "Renaming failed, see buffer `%s' for details." (buffer-name))))) - - (when (file-remote-p filename) - (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname))) - - (when (file-remote-p newname) - (with-parsed-tramp-file-name newname nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname)))))) + ;; Check if both files are local -- invoke normal rename-file. + ;; Otherwise, use Tramp from local system. + (setq filename (expand-file-name filename)) + (setq newname (expand-file-name newname)) + ;; At least one file a Tramp file? + (if (or (tramp-tramp-file-p filename) + (tramp-tramp-file-p newname)) + (tramp-gvfs-do-copy-or-rename-file + 'rename filename newname ok-if-already-exists t t) + (tramp-run-real-handler + 'rename-file (list filename newname ok-if-already-exists)))) (defun tramp-gvfs-handle-write-region - (start end filename &optional _append visit _lockname confirm) + (start end filename &optional append visit lockname confirm) "Like `write-region' for Tramp files." (with-parsed-tramp-file-name filename nil ;; XEmacs takes a coding system as the seventh argument, not `confirm'. @@ -1103,7 +1139,16 @@ is no information where to trace the message.") (tramp-error v 'file-error "File not overwritten"))) (let ((tmpfile (tramp-compat-make-temp-file filename))) - (write-region start end tmpfile) + (when (and append (file-exists-p filename)) + (copy-file filename tmpfile 'ok)) + ;; We say `no-message' here because we don't want the visited file + ;; modtime data to be clobbered from the temp file. We call + ;; `set-visited-file-modtime' ourselves later on. + (tramp-run-real-handler + 'write-region + (if confirm ; don't pass this arg unless defined for backward compat. + (list start end tmpfile append 'no-message lockname confirm) + (list start end tmpfile append 'no-message lockname))) (condition-case nil (rename-file tmpfile filename 'ok-if-already-exists) (error @@ -1129,7 +1174,7 @@ is no information where to trace the message.") (defun tramp-gvfs-url-file-name (filename) "Return FILENAME in URL syntax." ;; "/" must NOT be hexlified. - (let ((url-unreserved-chars (append '(?/) url-unreserved-chars)) + (let ((url-unreserved-chars (cons ?/ url-unreserved-chars)) result) (setq result @@ -1140,9 +1185,9 @@ is no information where to trace the message.") (setq user (concat (match-string 2 user) ";" (match-string 1 user)))) (url-parse-make-urlobj - method (url-hexify-string user) nil + method (and user (url-hexify-string user)) nil (tramp-file-name-real-host v) (tramp-file-name-port v) - (url-hexify-string localname) nil nil t)) + (and localname (url-hexify-string localname)) nil nil t)) (url-parse-make-urlobj "file" nil nil nil nil (url-hexify-string (file-truename filename)) nil nil t)))) @@ -1158,7 +1203,8 @@ is no information where to trace the message.") (defun tramp-gvfs-file-name (object-path) "Retrieve file name from D-Bus OBJECT-PATH." (dbus-unescape-from-identifier - (replace-regexp-in-string "^.*/\\([^/]+\\)$" "\\1" object-path))) + (tramp-compat-replace-regexp-in-string + "^.*/\\([^/]+\\)$" "\\1" object-path))) (defun tramp-bluez-address (device) "Return bluetooth device address from a given bluetooth DEVICE name." @@ -1201,10 +1247,14 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (zerop (logand flags tramp-gvfs-password-need-username)))) (setq user (read-string "User name: "))) (when (and (zerop (length domain)) - (not (zerop (logand flags tramp-gvfs-password-need-domain)))) + (not + (zerop (logand flags tramp-gvfs-password-need-domain)))) (setq domain (read-string "Domain name: "))) (tramp-message l 6 "%S %S %S %d" message user domain flags) + (unless (tramp-get-connection-property l "first-password-request" nil) + (tramp-clear-passwd l)) + (setq tramp-current-method l-method tramp-current-user user tramp-current-host l-host @@ -1289,12 +1339,14 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (cadr (assoc "port" (cadr mount-spec))))) (ssl (tramp-gvfs-dbus-byte-array-to-string (cadr (assoc "ssl" (cadr mount-spec))))) - (prefix (concat (tramp-gvfs-dbus-byte-array-to-string - (car mount-spec)) - (tramp-gvfs-dbus-byte-array-to-string - (cadr (assoc "share" (cadr mount-spec))))))) - (when (string-match "^smb" method) - (setq method "smb")) + (prefix (concat + (tramp-gvfs-dbus-byte-array-to-string + (car mount-spec)) + (tramp-gvfs-dbus-byte-array-to-string + (or (cadr (assoc "share" (cadr mount-spec))) + (cadr (assoc "volume" (cadr mount-spec)))))))) + (when (string-match "^\\(afp\\|smb\\)" method) + (setq method (match-string 1 method))) (when (string-equal "obex" method) (setq host (tramp-bluez-device host))) (when (and (string-equal "dav" method) (string-equal "true" ssl)) @@ -1371,12 +1423,15 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." (cadr (assoc "port" (cadr mount-spec))))) (ssl (tramp-gvfs-dbus-byte-array-to-string (cadr (assoc "ssl" (cadr mount-spec))))) - (prefix (concat (tramp-gvfs-dbus-byte-array-to-string - (car mount-spec)) - (tramp-gvfs-dbus-byte-array-to-string - (cadr (assoc "share" (cadr mount-spec))))))) - (when (string-match "^smb" method) - (setq method "smb")) + (prefix (concat + (tramp-gvfs-dbus-byte-array-to-string + (car mount-spec)) + (tramp-gvfs-dbus-byte-array-to-string + (or + (cadr (assoc "share" (cadr mount-spec))) + (cadr (assoc "volume" (cadr mount-spec)))))))) + (when (string-match "^\\(afp\\|smb\\)" method) + (setq method (match-string 1 method))) (when (string-equal "obex" method) (setq host (tramp-bluez-device host))) (when (and (string-equal "dav" method) (string-equal "true" ssl)) @@ -1416,48 +1471,43 @@ It was \"a(say)\", but has changed to \"a{sv})\"." (host (tramp-file-name-real-host vec)) (port (tramp-file-name-port vec)) (localname (tramp-file-name-localname vec)) - (ssl (if (string-match "^davs" method) "true" "false")) - (mount-spec '(:array)) - (mount-pref "/")) - - (setq - mount-spec - (append - mount-spec - (cond - ((string-equal "smb" method) - (string-match "^/?\\([^/]+\\)" localname) - (list (tramp-gvfs-mount-spec-entry "type" "smb-share") - (tramp-gvfs-mount-spec-entry "server" host) - (tramp-gvfs-mount-spec-entry "share" (match-string 1 localname)))) - ((string-equal "obex" method) - (list (tramp-gvfs-mount-spec-entry "type" method) - (tramp-gvfs-mount-spec-entry - "host" (concat "[" (tramp-bluez-address host) "]")))) - ((string-match "^dav" method) - (list (tramp-gvfs-mount-spec-entry "type" "dav") - (tramp-gvfs-mount-spec-entry "host" host) - (tramp-gvfs-mount-spec-entry "ssl" ssl))) - (t - (list (tramp-gvfs-mount-spec-entry "type" method) - (tramp-gvfs-mount-spec-entry "host" host)))))) - - (when user - (add-to-list - 'mount-spec (tramp-gvfs-mount-spec-entry "user" user) 'append)) - - (when domain - (add-to-list - 'mount-spec (tramp-gvfs-mount-spec-entry "domain" domain) 'append)) - - (when port - (add-to-list - 'mount-spec (tramp-gvfs-mount-spec-entry "port" (number-to-string port)) - 'append)) - - (when (and (string-match "^dav" method) - (string-match "^/?[^/]+" localname)) - (setq mount-pref (match-string 0 localname))) + (share (when (string-match "^/?\\([^/]+\\)" localname) + (match-string 1 localname))) + (ssl (when (string-match "^davs" method) "true" "false")) + (mount-spec + `(:array + ,@(cond + ((string-equal "smb" method) + (list (tramp-gvfs-mount-spec-entry "type" "smb-share") + (tramp-gvfs-mount-spec-entry "server" host) + (tramp-gvfs-mount-spec-entry "share" share))) + ((string-equal "obex" method) + (list (tramp-gvfs-mount-spec-entry "type" method) + (tramp-gvfs-mount-spec-entry + "host" (concat "[" (tramp-bluez-address host) "]")))) + ((string-match "\\`dav" method) + (list (tramp-gvfs-mount-spec-entry "type" "dav") + (tramp-gvfs-mount-spec-entry "host" host) + (tramp-gvfs-mount-spec-entry "ssl" ssl))) + ((string-equal "afp" method) + (list (tramp-gvfs-mount-spec-entry "type" "afp-volume") + (tramp-gvfs-mount-spec-entry "host" host) + (tramp-gvfs-mount-spec-entry "volume" share))) + (t + (list (tramp-gvfs-mount-spec-entry "type" method) + (tramp-gvfs-mount-spec-entry "host" host)))) + ,@(when user + (list (tramp-gvfs-mount-spec-entry "user" user))) + ,@(when domain + (list (tramp-gvfs-mount-spec-entry "domain" domain))) + ,@(when port + (list (tramp-gvfs-mount-spec-entry + "port" (number-to-string port)))))) + (mount-pref + (if (and (string-match "\\`dav" method) + (string-match "^/?[^/]+" localname)) + (match-string 0 localname) + "/"))) ;; Return. `(:struct ,(tramp-gvfs-dbus-string-to-byte-array mount-pref) ,mount-spec))) @@ -1469,6 +1519,7 @@ It was \"a(say)\", but has changed to \"a{sv})\"." "Maybe open a connection VEC. Does not do anything if a connection is already open, but re-opens the connection if a previous connection has died for some reason." + (tramp-check-proper-method-and-host vec) ;; We set the file name, in case there are incoming D-Bus signals or ;; D-Bus errors. @@ -1497,13 +1548,17 @@ connection if a previous connection has died for some reason." (string-equal localname "/")) (tramp-error vec 'file-error "Filename must contain a Windows share")) + (when (and (string-equal method "afp") + (string-equal localname "/")) + (tramp-error vec 'file-error "Filename must contain an AFP volume")) + (with-tramp-progress-reporter vec 3 (if (zerop (length user)) (format "Opening connection for %s using %s" host method) (format "Opening connection for %s@%s using %s" user host method)) - ;; Enable auth-source and password-cache. + ;; Enable `auth-source'. (tramp-set-connection-property vec "first-password-request" t) ;; There will be a callback of "askPassword" when a password is @@ -1546,7 +1601,7 @@ connection if a previous connection has died for some reason." ;; indicated by the "mounted" signal, i.e. the "fuse-mountpoint" ;; file property. (with-timeout - ((or (tramp-get-method-parameter method 'tramp-connection-timeout) + ((or (tramp-get-method-parameter vec 'tramp-connection-timeout) tramp-connection-timeout) (if (zerop (length (tramp-file-name-user vec))) (tramp-error @@ -1562,32 +1617,28 @@ connection if a previous connection has died for some reason." ;; is marked with the fuse-mountpoint "/". We shall react. (when (string-equal (tramp-get-file-property vec "/" "fuse-mountpoint" "") "/") - (tramp-error vec 'file-error "FUSE mount denied")) - - ;; In `tramp-check-cached-permissions', the connection - ;; properties {uig,gid}-{integer,string} are used. We set - ;; them to their local counterparts. - (tramp-set-connection-property - vec "uid-integer" (tramp-get-local-uid 'integer)) - (tramp-set-connection-property - vec "gid-integer" (tramp-get-local-gid 'integer)) - (tramp-set-connection-property - vec "uid-string" (tramp-get-local-uid 'string)) - (tramp-set-connection-property - vec "gid-string" (tramp-get-local-gid 'string)))))) + (tramp-error vec 'file-error "FUSE mount denied"))))) + + ;; In `tramp-check-cached-permissions', the connection properties + ;; {uig,gid}-{integer,string} are used. We set them to their local + ;; counterparts. + (with-tramp-connection-property + vec "uid-integer" (tramp-get-local-uid 'integer)) + (with-tramp-connection-property + vec "gid-integer" (tramp-get-local-gid 'integer)) + (with-tramp-connection-property + vec "uid-string" (tramp-get-local-uid 'string)) + (with-tramp-connection-property + vec "gid-string" (tramp-get-local-gid 'string))) (defun tramp-gvfs-send-command (vec command &rest args) "Send the COMMAND with its ARGS to connection VEC. COMMAND is usually a command from the gvfs-* utilities. -`call-process' is applied, and it returns `t' if the return code is zero." - (let (result) - (with-current-buffer (tramp-get-connection-buffer vec) - (tramp-gvfs-maybe-open-connection vec) - (erase-buffer) - (tramp-message vec 6 "%s %s" command (mapconcat 'identity args " ")) - (setq result (apply 'tramp-call-process command nil t nil args)) - (tramp-message vec 6 "\n%s" (buffer-string)) - (zerop result)))) +`call-process' is applied, and it returns t if the return code is zero." + (with-current-buffer (tramp-get-connection-buffer vec) + (tramp-gvfs-maybe-open-connection vec) + (erase-buffer) + (zerop (apply 'tramp-call-process vec command nil t nil args)))) ;; D-Bus BLUEZ functions. @@ -1637,9 +1688,10 @@ be used." :system tramp-bluez-service (dbus-event-path-name last-input-event) tramp-bluez-interface-adapter "StopDiscovery"))))) -(dbus-register-signal - :system nil nil tramp-bluez-interface-adapter "PropertyChanged" - 'tramp-bluez-property-changed) +(when tramp-gvfs-enabled + (dbus-register-signal + :system nil nil tramp-bluez-interface-adapter "PropertyChanged" + 'tramp-bluez-property-changed)) (defun tramp-bluez-device-found (device args) "Signal handler for the \"org.bluez.Adapter.DeviceFound\" signal." @@ -1650,9 +1702,10 @@ be used." ;; device, and call also SDP in order to find the obex service. (add-to-list 'tramp-bluez-devices (list alias address)))) -(dbus-register-signal - :system nil nil tramp-bluez-interface-adapter "DeviceFound" - 'tramp-bluez-device-found) +(when tramp-gvfs-enabled + (dbus-register-signal + :system nil nil tramp-bluez-interface-adapter "DeviceFound" + 'tramp-bluez-device-found)) (defun tramp-bluez-parse-device-names (_ignore) "Return a list of (nil host) tuples allowed to access." @@ -1661,19 +1714,20 @@ be used." (tramp-bluez-list-devices))) ;; Add completion function for OBEX method. -(when (member tramp-bluez-service (dbus-list-known-names :system)) +(when (and tramp-gvfs-enabled + (member tramp-bluez-service (dbus-list-known-names :system))) (tramp-set-completion-function "obex" '((tramp-bluez-parse-device-names "")))) ;; D-Bus zeroconf functions. -(defun tramp-zeroconf-parse-workstation-device-names (_ignore) +(defun tramp-zeroconf-parse-service-device-names (service) "Return a list of (user host) tuples allowed to access." (mapcar (lambda (x) (list nil (zeroconf-service-host x))) - (zeroconf-list-services "_workstation._tcp"))) + (zeroconf-list-services service))) (defun tramp-zeroconf-parse-webdav-device-names (_ignore) "Return a list of (user host) tuples allowed to access." @@ -1693,15 +1747,20 @@ be used." (list user host))) (zeroconf-list-services "_webdav._tcp"))) -;; Add completion function for DAV and DAVS methods. -(when (member zeroconf-service-avahi (dbus-list-known-names :system)) +;; Add completion functions for AFP, DAV, DAVS, SFTP and SMB methods. +(when (and tramp-gvfs-enabled + (member zeroconf-service-avahi (dbus-list-known-names :system))) (zeroconf-init tramp-gvfs-zeroconf-domain) (tramp-set-completion-function - "sftp" '((tramp-zeroconf-parse-workstation-device-names ""))) + "afp" '((tramp-zeroconf-parse-service-device-names "_afpovertcp._tcp"))) (tramp-set-completion-function "dav" '((tramp-zeroconf-parse-webdav-device-names ""))) (tramp-set-completion-function - "davs" '((tramp-zeroconf-parse-webdav-device-names "")))) + "davs" '((tramp-zeroconf-parse-webdav-device-names ""))) + (tramp-set-completion-function + "sftp" '((tramp-zeroconf-parse-service-device-names "_workstation._tcp"))) + (tramp-set-completion-function + "smb" '((tramp-zeroconf-parse-service-device-names "_smb._tcp")))) ;; D-Bus SYNCE functions. @@ -1717,11 +1776,13 @@ They are retrieved from the hal daemon." (when (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t :system tramp-hal-service device tramp-hal-interface-device "PropertyExists" "sync.plugin") - (add-to-list - 'tramp-synce-devices - (with-tramp-dbus-call-method tramp-gvfs-dbus-event-vector t - :system tramp-hal-service device tramp-hal-interface-device - "GetPropertyString" "pda.pocketpc.name")))) + (let ((prop + (with-tramp-dbus-call-method + tramp-gvfs-dbus-event-vector t + :system tramp-hal-service device tramp-hal-interface-device + "GetPropertyString" "pda.pocketpc.name"))) + (unless (member prop tramp-synce-devices) + (push prop tramp-synce-devices))))) (tramp-message tramp-gvfs-dbus-event-vector 10 "%s" tramp-synce-devices) tramp-synce-devices)) @@ -1732,8 +1793,9 @@ They are retrieved from the hal daemon." (tramp-synce-list-devices))) ;; Add completion function for SYNCE method. -(tramp-set-completion-function - "synce" '((tramp-synce-parse-device-names ""))) +(when tramp-gvfs-enabled + (tramp-set-completion-function + "synce" '((tramp-synce-parse-device-names "")))) (add-hook 'tramp-unload-hook (lambda () @@ -1743,7 +1805,7 @@ They are retrieved from the hal daemon." ;;; TODO: -;; * Host name completion via smb-server or smb-network. +;; * Host name completion via afp-server, smb-server or smb-network. ;; * Check how two shares of the same SMB server can be mounted in ;; parallel. ;; * Apply SDP on bluetooth devices, in order to filter out obex diff --git a/lisp/net/tramp-gw.el b/lisp/net/tramp-gw.el index 53dbdbc45d4..5e22f6a3b59 100644 --- a/lisp/net/tramp-gw.el +++ b/lisp/net/tramp-gw.el @@ -1,6 +1,6 @@ ;;; tramp-gw.el --- Tramp utility functions for HTTP tunnels and SOCKS gateways -;; Copyright (C) 2007-2013 Free Software Foundation, Inc. +;; Copyright (C) 2007-2015 Free Software Foundation, Inc. ;; Author: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes @@ -96,7 +96,7 @@ (unless (memq (process-status proc) '(run open)) (tramp-message tramp-gw-vector 4 "Deleting auxiliary process `%s'" tramp-gw-gw-proc) - (let* (tramp-verbose + (let* ((tramp-verbose 0) (p (tramp-get-connection-property proc "process" nil))) (when (processp p) (delete-process p))))) @@ -111,7 +111,7 @@ (tramp-compat-set-process-query-on-exit-flag proc nil) ;; We don't want debug messages, because the corresponding debug ;; buffer might be undecided. - (let (tramp-verbose) + (let ((tramp-verbose 0)) (tramp-set-connection-property tramp-gw-gw-proc "process" proc) (tramp-set-connection-property proc "process" tramp-gw-gw-proc)) ;; Set the process-filter functions for both processes. @@ -125,9 +125,12 @@ (tramp-gw-process-filter tramp-gw-gw-proc s)))))) (defun tramp-gw-process-filter (proc string) - (let (tramp-verbose) - (process-send-string - (tramp-get-connection-property proc "process" nil) string))) + (let ((tramp-verbose 0)) + ;; The other process might have been stopped already. We don't + ;; want to be interrupted then. + (ignore-errors + (process-send-string + (tramp-get-connection-property proc "process" nil) string)))) ;;;###tramp-autoload (defun tramp-gw-open-connection (vec gw-vec target-vec) @@ -195,11 +198,12 @@ instead of the host name declared in TARGET-VEC." (setq tramp-gw-gw-proc (funcall socks-function - (tramp-get-connection-name gw-vec) - (tramp-get-connection-buffer gw-vec) + (let ((tramp-verbose 0)) (tramp-get-connection-name gw-vec)) + (let ((tramp-verbose 0)) (tramp-get-connection-buffer gw-vec)) (tramp-file-name-real-host target-vec) (tramp-file-name-port target-vec))) (set-process-sentinel tramp-gw-gw-proc 'tramp-gw-gw-proc-sentinel) + (set-process-coding-system tramp-gw-gw-proc 'binary 'binary) (tramp-compat-set-process-query-on-exit-flag tramp-gw-gw-proc nil) (tramp-message vec 4 "Opened %s process `%s'" @@ -238,14 +242,14 @@ authentication is requested from proxy server, provide it." tramp-gw-vector 6 "\n%s" (format "%s%s\r\n" command - (replace-regexp-in-string ;; no password in trace! + (tramp-compat-replace-regexp-in-string ;; no password in trace! "Basic [^\r\n]+" "Basic xxxxx" authentication t))) (with-current-buffer buffer ;; Trap errors to be traced in the right trace buffer. Often, ;; proxies have a timeout of 60". We wait 65" in order to ;; receive an answer this case. (ignore-errors - (let (tramp-verbose) + (let ((tramp-verbose 0)) (tramp-wait-for-regexp proc 65 "\r?\n\r?\n"))) ;; Check return code. (goto-char (point-min)) @@ -260,6 +264,10 @@ authentication is requested from proxy server, provide it." (200 (setq found t)) ;; We need basic authentication. (401 (setq authentication (tramp-gw-basic-authentication nil first))) + ;; Access forbidden. + (403 (tramp-error-with-buffer + (current-buffer) tramp-gw-vector 'file-error + "Connection to %s:%d forbidden." host service)) ;; Target host not found. (404 (tramp-error-with-buffer (current-buffer) tramp-gw-vector 'file-error diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index e41ed36f597..1753c73f869 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -1,6 +1,6 @@ ;;; tramp-sh.el --- Tramp access functions for (s)sh-like connections -;; Copyright (C) 1998-2013 Free Software Foundation, Inc. +;; Copyright (C) 1998-2015 Free Software Foundation, Inc. ;; (copyright statements below in code to be updated with the above notice) @@ -35,7 +35,12 @@ (defvar directory-sep-char) (defvar tramp-gw-tunnel-method) (defvar tramp-gw-socks-method) +(defvar vc-handled-backends) +(defvar vc-bzr-program) +(defvar vc-git-program) +(defvar vc-hg-program) +;;;###tramp-autoload (defcustom tramp-inline-compress-start-size 4096 "The minimum size of compressing where inline transfer. When inline transfer, compress transferred data of file @@ -44,6 +49,7 @@ If it is nil, no compression at all will be applied." :group 'tramp :type '(choice (const nil) integer)) +;;;###tramp-autoload (defcustom tramp-copy-size-limit 10240 "The maximum file size where inline copying is preferred over an \ out-of-the-band copy. @@ -60,6 +66,25 @@ files conditionalize this setup based on the TERM environment variable." :group 'tramp :type 'string) +;;;###tramp-autoload +(defcustom tramp-histfile-override ".tramp_history" + "When invoking a shell, override the HISTFILE with this value. +When setting to a string, it redirects the shell history to that +file. Be careful when setting to \"/dev/null\"; this might +result in undesired results when using \"bash\" as shell. + +The value t, the default value, unsets any setting of HISTFILE, +and sets both HISTFILESIZE and HISTSIZE to 0. 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 "Unset HISTFILE" t) + (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.") @@ -72,13 +97,37 @@ files conditionalize this setup based on the TERM environment variable." "///%s#$" (md5 (concat (prin1-to-string process-environment) (current-time-string)))) "String used to recognize end of output. -The '$' character at the end is quoted; the string cannot be +The `$' character at the end is quoted; the string cannot be detected as prompt when being sent on echoing hosts, therefore.") ;;;###tramp-autoload (defconst tramp-initial-end-of-output "#$ " "Prompt when establishing a connection.") +(defconst tramp-end-of-heredoc (md5 tramp-end-of-output) + "String used to recognize end of heredoc strings.") + +;;;###tramp-autoload +(defcustom tramp-use-ssh-controlmaster-options t + "Whether to use `tramp-ssh-controlmaster-options'." + :group 'tramp + :version "24.4" + :type 'boolean) + +(defvar tramp-ssh-controlmaster-options nil + "Which ssh Control* arguments to use. + +If it is a string, it should have the form +\"-o ControlMaster=auto -o ControlPath='tramp.%%r@%%h:%%p' +-o ControlPersist=no\". Percent characters in the ControlPath +spec must be doubled, because the string is used as format string. + +Otherwise, it will be auto-detected by Tramp, if +`tramp-use-ssh-controlmaster-options' is non-nil. The value +depends on the installed local ssh version. + +The string is used in `tramp-methods'.") + ;; Initialize `tramp-methods' with the supported methods. ;;;###tramp-autoload (add-to-list 'tramp-methods @@ -86,6 +135,7 @@ detected as prompt when being sent on echoing hosts, therefore.") (tramp-login-program "rsh") (tramp-login-args (("%h") ("-l" "%u"))) (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) (tramp-copy-program "rcp") (tramp-copy-args (("-p" "%k") ("-r"))) @@ -97,6 +147,7 @@ detected as prompt when being sent on echoing hosts, therefore.") (tramp-login-program "remsh") (tramp-login-args (("%h") ("-l" "%u"))) (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) (tramp-copy-program "rcp") (tramp-copy-args (("-p" "%k"))) @@ -109,6 +160,7 @@ detected as prompt when being sent on echoing hosts, therefore.") ("-e" "none") ("%h"))) (tramp-async-args (("-q"))) (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) (tramp-copy-program "scp") (tramp-copy-args (("-P" "%p") ("-p" "%k") ("-q") ("-r") ("%c"))) @@ -126,6 +178,7 @@ detected as prompt when being sent on echoing hosts, therefore.") ("-e" "none") ("-t" "-t") ("%h") ("/bin/sh"))) (tramp-async-args (("-q"))) (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) (tramp-copy-program "scp") (tramp-copy-args (("-P" "%p") ("-p" "%k") @@ -138,23 +191,13 @@ detected as prompt when being sent on echoing hosts, therefore.") (tramp-default-port 22))) ;;;###tramp-autoload (add-to-list 'tramp-methods - '("sftp" - (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") - ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-shell "/bin/sh") - (tramp-remote-shell-args ("-c")) - (tramp-copy-program "sftp") - (tramp-copy-args ("%c")))) - ;;;###tramp-autoload -(add-to-list 'tramp-methods '("rsync" (tramp-login-program "ssh") (tramp-login-args (("-l" "%u") ("-p" "%p") ("%c") ("-e" "none") ("%h"))) (tramp-async-args (("-q"))) (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) (tramp-copy-program "rsync") (tramp-copy-args (("-t" "%k") ("-r"))) @@ -168,6 +211,7 @@ detected as prompt when being sent on echoing hosts, therefore.") (tramp-login-program "rsh") (tramp-login-args (("%h") ("-l" "%u"))) (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")))) ;;;###tramp-autoload (add-to-list 'tramp-methods @@ -175,6 +219,7 @@ detected as prompt when being sent on echoing hosts, therefore.") (tramp-login-program "remsh") (tramp-login-args (("%h") ("-l" "%u"))) (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")))) ;;;###tramp-autoload (add-to-list 'tramp-methods @@ -184,6 +229,7 @@ detected as prompt when being sent on echoing hosts, therefore.") ("-e" "none") ("%h"))) (tramp-async-args (("-q"))) (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") ("-o" "UserKnownHostsFile=/dev/null") @@ -197,6 +243,7 @@ detected as prompt when being sent on echoing hosts, therefore.") ("-e" "none") ("-t" "-t") ("%h") ("/bin/sh"))) (tramp-async-args (("-q"))) (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") ("-o" "UserKnownHostsFile=/dev/null") @@ -206,9 +253,27 @@ detected as prompt when being sent on echoing hosts, therefore.") (add-to-list 'tramp-methods '("telnet" (tramp-login-program "telnet") - (tramp-login-args (("%h") ("%p"))) + (tramp-login-args (("%h") ("%p") ("2>/dev/null"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) + (tramp-remote-shell-args ("-c")) + (tramp-default-port 23))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("nc" + (tramp-login-program "telnet") + (tramp-login-args (("%h") ("%p") ("2>/dev/null"))) (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) + (tramp-copy-program "nc") + ;; We use "-v" for better error tracking. + (tramp-copy-args (("-w" "1") ("-v") ("%h") ("%r"))) + (tramp-remote-copy-program "nc") + ;; We use "-p" as required for newer busyboxes. For older + ;; busybox/nc versions, the value must be (("-l") ("%r")). This + ;; can be achieved by tweaking `tramp-connection-properties'. + (tramp-remote-copy-args (("-l") ("-p" "%r") ("2>/dev/null"))) (tramp-default-port 23))) ;;;###tramp-autoload (add-to-list 'tramp-methods @@ -216,14 +281,21 @@ detected as prompt when being sent on echoing hosts, therefore.") (tramp-login-program "su") (tramp-login-args (("-") ("%u"))) (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) (tramp-connection-timeout 10))) ;;;###tramp-autoload (add-to-list 'tramp-methods '("sudo" (tramp-login-program "sudo") - (tramp-login-args (("-u" "%u") ("-s") ("-H") ("-p" "Password:"))) + ;; The password template must be masked. Otherwise, it could be + ;; interpreted as password prompt if the remote host echoes the command. + (tramp-login-args (("-u" "%u") ("-s") ("-H") + ("-p" "P\"\"a\"\"s\"\"s\"\"w\"\"o\"\"r\"\"d\"\":"))) + ;; Local $SHELL could be a nasty one, like zsh or fish. Let's override it. + (tramp-login-env (("SHELL") ("/bin/sh"))) (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) (tramp-connection-timeout 10))) ;;;###tramp-autoload @@ -232,6 +304,7 @@ detected as prompt when being sent on echoing hosts, therefore.") (tramp-login-program "ksu") (tramp-login-args (("%u") ("-q"))) (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) (tramp-connection-timeout 10))) ;;;###tramp-autoload @@ -240,35 +313,50 @@ detected as prompt when being sent on echoing hosts, therefore.") (tramp-login-program "krlogin") (tramp-login-args (("%h") ("-l" "%u") ("-x"))) (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")))) ;;;###tramp-autoload (add-to-list 'tramp-methods - '("plink" + `("plink" (tramp-login-program "plink") - (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%h"))) + ;; ("%h") must be a single element, see `tramp-compute-multi-hops'. + (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("-t") + ("%h") ("\"") + (,(format + "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" + tramp-terminal-type + tramp-initial-end-of-output)) + ("/bin/sh") ("\""))) (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) (tramp-default-port 22))) ;;;###tramp-autoload (add-to-list 'tramp-methods `("plinkx" (tramp-login-program "plink") - ;; ("%h") must be a single element, see - ;; `tramp-compute-multi-hops'. - (tramp-login-args (("-load") ("%h") ("-t") + (tramp-login-args (("-load") ("%h") ("-t") ("\"") (,(format "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" tramp-terminal-type tramp-initial-end-of-output)) - ("/bin/sh"))) + ("/bin/sh") ("\""))) (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")))) ;;;###tramp-autoload (add-to-list 'tramp-methods - '("pscp" + `("pscp" (tramp-login-program "plink") - (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%h"))) + (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("-t") + ("%h") ("\"") + (,(format + "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" + tramp-terminal-type + tramp-initial-end-of-output)) + ("/bin/sh") ("\""))) (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) (tramp-copy-program "pscp") (tramp-copy-args (("-l" "%u") ("-P" "%p") ("-scp") ("-p" "%k") @@ -278,10 +366,17 @@ detected as prompt when being sent on echoing hosts, therefore.") (tramp-default-port 22))) ;;;###tramp-autoload (add-to-list 'tramp-methods - '("psftp" + `("psftp" (tramp-login-program "plink") - (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%h"))) + (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("-t") + ("%h") ("\"") + (,(format + "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" + tramp-terminal-type + tramp-initial-end-of-output)) + ("/bin/sh") ("\""))) (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-c")) (tramp-copy-program "pscp") (tramp-copy-args (("-l" "%u") ("-P" "%p") ("-sftp") ("-p" "%k") @@ -294,6 +389,7 @@ detected as prompt when being sent on echoing hosts, therefore.") (tramp-login-program "fsh") (tramp-login-args (("%h") ("-l" "%u") ("sh" "-i"))) (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-login ("-l")) (tramp-remote-shell-args ("-i") ("-c")) (tramp-copy-program "fcp") (tramp-copy-args (("-p" "%k"))) @@ -313,7 +409,8 @@ detected as prompt when being sent on echoing hosts, therefore.") (add-to-list 'tramp-default-user-alist `(,(concat "\\`" - (regexp-opt '("rcp" "remcp" "rsh" "telnet" "krlogin" "fcp")) + (regexp-opt + '("rcp" "remcp" "rsh" "telnet" "nc" "krlogin" "fcp")) "\\'") nil ,(user-login-name))) @@ -364,7 +461,6 @@ detected as prompt when being sent on echoing hosts, therefore.") (tramp-set-completion-function "remcp" tramp-completion-function-alist-rsh) (tramp-set-completion-function "scp" tramp-completion-function-alist-ssh) (tramp-set-completion-function "scpx" tramp-completion-function-alist-ssh) - (tramp-set-completion-function "sftp" tramp-completion-function-alist-ssh) (tramp-set-completion-function "rsync" tramp-completion-function-alist-ssh) (tramp-set-completion-function "rsh" tramp-completion-function-alist-rsh) (tramp-set-completion-function "remsh" tramp-completion-function-alist-rsh) @@ -372,6 +468,7 @@ detected as prompt when being sent on echoing hosts, therefore.") (tramp-set-completion-function "sshx" tramp-completion-function-alist-ssh) (tramp-set-completion-function "telnet" tramp-completion-function-alist-telnet) + (tramp-set-completion-function "nc" tramp-completion-function-alist-telnet) (tramp-set-completion-function "su" tramp-completion-function-alist-su) (tramp-set-completion-function "sudo" tramp-completion-function-alist-su) (tramp-set-completion-function "ksu" tramp-completion-function-alist-su) @@ -381,6 +478,7 @@ detected as prompt when being sent on echoing hosts, therefore.") (tramp-set-completion-function "plinkx" tramp-completion-function-alist-putty) (tramp-set-completion-function "pscp" tramp-completion-function-alist-ssh) + (tramp-set-completion-function "psftp" tramp-completion-function-alist-ssh) (tramp-set-completion-function "fcp" tramp-completion-function-alist-ssh))) ;; "getconf PATH" yields: @@ -419,11 +517,10 @@ as given in your `~/.profile'." ;;;###tramp-autoload (defcustom tramp-remote-process-environment - `("HISTFILE=$HOME/.tramp_history" "HISTSIZE=1" "TMOUT=0" "LC_ALL=C" + `("TMOUT=0" "LC_CTYPE=''" ,(format "TERM=%s" tramp-terminal-type) - "EMACS=t" ;; Deprecated. ,(format "INSIDE_EMACS='%s,tramp:%s'" emacs-version tramp-version) - "CDPATH=" "HISTORY=" "MAIL=" "MAILCHECK=" "MAILPATH=" "PAGER=\"\"" + "CDPATH=" "HISTORY=" "MAIL=" "MAILCHECK=" "MAILPATH=" "PAGER=cat" "autocorrect=" "correct=") "List of environment variables to be set on the remote host. @@ -434,8 +531,10 @@ which might have been set in the init files like ~/.profile. Special handling is applied to the PATH environment, which should not be set here. Instead, it should be set via `tramp-remote-path'." :group 'tramp + :version "24.4" :type '(repeat string)) +;;;###tramp-autoload (defcustom tramp-sh-extra-args '(("/bash\\'" . "-norc -noprofile")) "Alist specifying extra arguments to pass to the remote shell. Entries are (REGEXP . ARGS) where REGEXP is a regular expression @@ -485,9 +584,9 @@ This list is used for copying/renaming with out-of-band methods. See `tramp-actions-before-shell' for more info.") (defconst tramp-uudecode - "(echo begin 600 /tmp/tramp.$$; tail +2) | uudecode -cat /tmp/tramp.$$ -rm -f /tmp/tramp.$$" + "(echo begin 600 %t; tail -n +2) | uudecode +cat %t +rm -f %t" "Shell function to implement `uudecode' to standard output. Many systems support `uudecode -o /dev/stdout' or `uudecode -o -' for this or `uudecode -p', but some systems don't, and for them @@ -578,6 +677,7 @@ if (!@stat) { if (($stat[2] & 0170000) == 0120000) { $type = readlink($ARGV[0]); + $type =~ s/\"/\\\\\"/g; $type = \"\\\"$type\\\"\"; } elsif (($stat[2] & 0170000) == 040000) @@ -627,6 +727,7 @@ for($i = 0; $i < $n; $i++) if (($stat[2] & 0170000) == 0120000) { $type = readlink($filename); + $type =~ s/\"/\\\\\"/g; $type = \"\\\"$type\\\"\"; } elsif (($stat[2] & 0170000) == 040000) @@ -639,6 +740,7 @@ for($i = 0; $i < $n; $i++) }; $uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\"; $gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\"; + $filename =~ s/\"/\\\\\"/g; printf( \"(\\\"%%s\\\" %%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u.0 %%u t (%%u . %%u) (%%u . %%u))\\n\", $filename, @@ -685,7 +787,7 @@ on the remote host.") (defconst tramp-perl-encode "%s -e ' # This script contributed by Juanma Barranquero <lektu@terra.es>. -# Copyright (C) 2002-2013 Free Software Foundation, Inc. +# Copyright (C) 2002-2015 Free Software Foundation, Inc. use strict; my %%trans = do { @@ -723,7 +825,7 @@ This string is passed to `format', so percent characters need to be doubled.") (defconst tramp-perl-decode "%s -e ' # This script contributed by Juanma Barranquero <lektu@terra.es>. -# Copyright (C) 2002-2013 Free Software Foundation, Inc. +# Copyright (C) 2002-2015 Free Software Foundation, Inc. use strict; my %%trans = do { @@ -774,6 +876,78 @@ Escape sequence %s is replaced with name of Perl binary.") "Perl program to use for decoding a file. Escape sequence %s is replaced with name of Perl binary.") +(defconst tramp-awk-encode + "od -v -t x1 -A n | busybox awk '\\ +BEGIN { + b64 = \"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/\" + b16 = \"0123456789abcdef\" +} +{ + for (c=1; c<=length($0); c++) { + d=index(b16, substr($0,c,1)) + if (d--) { + for (b=1; b<=4; b++) { + o=o*2+int(d/8); d=(d*2)%%16 + if (++obc==6) { + printf substr(b64,o+1,1) + if (++rc>75) { printf \"\\n\"; rc=0 } + obc=0; o=0 + } + } + } + } +} +END { + if (obc) { + tail=(obc==2) ? \"==\\n\" : \"=\\n\" + while (obc++<6) { o=o*2 } + printf \"%%c\", substr(b64,o+1,1) + } else { + tail=\"\\n\" + } + printf tail +}'" + "Awk program to use for encoding a file. +This string is passed to `format', so percent characters need to be doubled.") + +(defconst tramp-awk-decode + "busybox awk '\\ +BEGIN { + b64 = \"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/\" +} +{ + for (i=1; i<=length($0); i++) { + c=index(b64, substr($0,i,1)) + if(c--) { + for(b=0; b<6; b++) { + o=o*2+int(c/32); c=(c*2)%%64 + if(++obc==8) { + if (o) { + printf \"%%c\", o + } else { + system(\"dd if=/dev/zero bs=1 count=1 2>/dev/null\") + } + obc=0; o=0 + } + } + } + } +}'" + "Awk program to use for decoding a file. +This string is passed to `format', so percent characters need to be doubled.") + +(defconst tramp-awk-coding-test + "test -c /dev/zero && \ +od -v -t x1 -A n </dev/null && \ +busybox awk '{}' </dev/null" + "Test command for checking `tramp-awk-encode' and `tramp-awk-decode'.") + +(defconst tramp-stat-marker "/////" + "Marker in stat commands for file attributes.") + +(defconst tramp-stat-quoted-marker "\\/\\/\\/\\/\\/" + "Quoted marker in stat commands for file attributes.") + (defconst tramp-vc-registered-read-file-names "echo \"(\" while read file; do @@ -834,6 +1008,7 @@ of command line.") (file-newer-than-file-p . tramp-sh-handle-file-newer-than-file-p) (file-notify-add-watch . tramp-sh-handle-file-notify-add-watch) (file-notify-rm-watch . tramp-handle-file-notify-rm-watch) + (file-notify-valid-p . tramp-handle-file-notify-valid-p) (file-ownership-preserved-p . tramp-sh-handle-file-ownership-preserved-p) (file-readable-p . tramp-sh-handle-file-readable-p) (file-regular-p . tramp-handle-file-regular-p) @@ -850,7 +1025,7 @@ of command line.") (insert-file-contents-literally . tramp-sh-handle-insert-file-contents-literally) (load . tramp-handle-load) - (make-auto-save-file-name . tramp-sh-handle-make-auto-save-file-name) + (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-sh-handle-make-directory) (make-symbolic-link . tramp-sh-handle-make-symbolic-link) (process-file . tramp-sh-handle-process-file) @@ -934,20 +1109,25 @@ target of the symlink differ." (defun tramp-sh-handle-file-truename (filename) "Like `file-truename' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (tramp-make-tramp-file-name method user host + (format + "%s%s" + (with-parsed-tramp-file-name (expand-file-name filename) nil + (tramp-make-tramp-file-name + method user host (with-tramp-file-property v localname "file-truename" (let ((result nil)) ; result steps in reverse order (tramp-message v 4 "Finding true name for `%s'" filename) (cond ;; Use GNU readlink --canonicalize-missing where available. ((tramp-get-remote-readlink v) - (setq result - (tramp-send-command-and-read - v - (format "echo \"\\\"`%s --canonicalize-missing %s`\\\"\"" - (tramp-get-remote-readlink v) - (tramp-shell-quote-argument localname))))) + (tramp-send-command-and-check + v + (format "%s --canonicalize-missing %s" + (tramp-get-remote-readlink v) + (tramp-shell-quote-argument localname))) + (with-current-buffer (tramp-get-connection-buffer v) + (goto-char (point-min)) + (setq result (buffer-substring (point-min) (point-at-eol))))) ;; Use Perl implementation. ((and (tramp-get-remote-perl v) @@ -1038,7 +1218,10 @@ target of the symlink differ." (setq result (concat result "/")))))) (tramp-message v 4 "True name of `%s' is `%s'" localname result) - result))))) + result)))) + + ;; Preserve trailing "/". + (if (string-equal (file-name-nondirectory filename) "") "/" ""))) ;; Basic functions. @@ -1060,23 +1243,24 @@ target of the symlink differ." (defun tramp-sh-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." (unless id-format (setq id-format 'integer)) - ;; Don't modify `last-coding-system-used' by accident. - (let ((last-coding-system-used last-coding-system-used)) - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-tramp-file-property - v localname (format "file-attributes-%s" id-format) - (save-excursion - (tramp-convert-file-attributes - v - (or - (cond - ((tramp-get-remote-stat v) - (tramp-do-file-attributes-with-stat v localname id-format)) - ((tramp-get-remote-perl v) - (tramp-do-file-attributes-with-perl v localname id-format)) - (t nil)) - ;; The scripts could fail, for example with huge file size. - (tramp-do-file-attributes-with-ls v localname id-format)))))))) + (ignore-errors + ;; Don't modify `last-coding-system-used' by accident. + (let ((last-coding-system-used last-coding-system-used)) + (with-parsed-tramp-file-name (expand-file-name filename) nil + (with-tramp-file-property + v localname (format "file-attributes-%s" id-format) + (save-excursion + (tramp-convert-file-attributes + v + (or + (cond + ((tramp-get-remote-stat v) + (tramp-do-file-attributes-with-stat v localname id-format)) + ((tramp-get-remote-perl v) + (tramp-do-file-attributes-with-perl v localname id-format)) + (t nil)) + ;; The scripts could fail, for example with huge file size. + (tramp-do-file-attributes-with-ls v localname id-format))))))))) (defun tramp-do-file-attributes-with-ls (vec localname &optional id-format) "Implement `file-attributes' for Tramp files using the ls(1) command." @@ -1086,15 +1270,19 @@ target of the symlink differ." (tramp-message vec 5 "file attributes with ls: %s" localname) (tramp-send-command vec - (format "(%s %s || %s -h %s) && %s %s %s" + (format "(%s %s || %s -h %s) && %s %s %s %s" (tramp-get-file-exists-command vec) (tramp-shell-quote-argument localname) (tramp-get-test-command vec) (tramp-shell-quote-argument localname) (tramp-get-ls-command vec) + ;; On systems which have no quoting style, file names + ;; with special characters could fail. + (if (tramp-get-ls-command-with-quoting-style vec) + "--quoting-style=c" "") (if (eq id-format 'integer) "-ildn" "-ild") (tramp-shell-quote-argument localname))) - ;; parse `ls -l' output ... + ;; Parse `ls -l' output ... (with-current-buffer (tramp-get-buffer vec) (when (> (buffer-size) 0) (goto-char (point-min)) @@ -1133,11 +1321,14 @@ target of the symlink differ." ;; From the file modes, figure out other stuff. (setq symlinkp (eq ?l (aref res-filemodes 0))) (setq dirp (eq ?d (aref res-filemodes 0))) - ;; if symlink, find out file name pointed to + ;; If symlink, find out file name pointed to. (when symlinkp (search-forward "-> ") - (setq res-symlink-target (buffer-substring (point) (point-at-eol)))) - ;; return data gathered + (setq res-symlink-target + (if (tramp-get-ls-command-with-quoting-style vec) + (read (current-buffer)) + (buffer-substring (point) (point-at-eol))))) + ;; Return data gathered. (list ;; 0. t for directory, string (name linked to) for symbolic ;; link, or nil. @@ -1160,9 +1351,9 @@ target of the symlink differ." ;; 8. File modes, as a string of ten letters or dashes as in ls -l. res-filemodes ;; 9. t if file's gid would change if file were deleted and - ;; recreated. Will be set in `tramp-convert-file-attributes' + ;; recreated. Will be set in `tramp-convert-file-attributes'. t - ;; 10. inode number. + ;; 10. Inode number. res-inode ;; 11. Device number. Will be replaced by a virtual device number. -1 @@ -1186,17 +1377,28 @@ target of the symlink differ." (tramp-send-command-and-read vec (format - ;; On Opsware, pdksh (which is the true name of ksh there) doesn't - ;; parse correctly the sequence "((". Therefore, we add a space. - "( (%s %s || %s -h %s) && %s -c '((\"%%N\") %%h %s %s %%Xe0 %%Ye0 %%Ze0 %%se0 \"%%A\" t %%ie0 -1)' %s || echo nil)" + (concat + ;; On Opsware, pdksh (which is the true name of ksh there) + ;; doesn't parse correctly the sequence "((". Therefore, we add + ;; a space. Apostrophes in the stat output are masked as + ;; `tramp-stat-marker', in order to make a proper shell escape of + ;; them in file names. + "( (%s %s || %s -h %s) && (%s -c " + "'((%s%%N%s) %%h %s %s %%Xe0 %%Ye0 %%Ze0 %%se0 %s%%A%s t %%ie0 -1)' " + "%s | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g') || echo nil)") (tramp-get-file-exists-command vec) (tramp-shell-quote-argument localname) (tramp-get-test-command vec) (tramp-shell-quote-argument localname) (tramp-get-remote-stat vec) - (if (eq id-format 'integer) "%ue0" "\"%U\"") - (if (eq id-format 'integer) "%ge0" "\"%G\"") - (tramp-shell-quote-argument localname)))) + tramp-stat-marker tramp-stat-marker + (if (eq id-format 'integer) + "%ue0" (concat tramp-stat-marker "%U" tramp-stat-marker)) + (if (eq id-format 'integer) + "%ge0" (concat tramp-stat-marker "%G" tramp-stat-marker)) + tramp-stat-marker tramp-stat-marker + (tramp-shell-quote-argument localname) + tramp-stat-quoted-marker))) (defun tramp-sh-handle-set-visited-file-modtime (&optional time-list) "Like `set-visited-file-modtime' for Tramp files." @@ -1224,8 +1426,7 @@ target of the symlink differ." (format "%s -ild %s" (tramp-get-ls-command v) (tramp-shell-quote-argument localname))) - (setq attr (buffer-substring (point) - (progn (end-of-line) (point))))) + (setq attr (buffer-substring (point) (point-at-eol)))) (tramp-set-file-property v localname "visited-file-modtime-ild" attr)) (when (boundp 'last-coding-system-used) @@ -1234,14 +1435,14 @@ target of the symlink differ." ;; This function makes the same assumption as ;; `tramp-sh-handle-set-visited-file-modtime'. -(defun tramp-sh-handle-verify-visited-file-modtime (buf) +(defun tramp-sh-handle-verify-visited-file-modtime (&optional buf) "Like `verify-visited-file-modtime' for Tramp files. At the time `verify-visited-file-modtime' calls this function, we already know that the buffer is visiting a file and that `visited-file-modtime' does not return 0. Do not call this function directly, unless those two cases are already taken care of." - (with-current-buffer buf + (with-current-buffer (or buf (current-buffer)) (let ((f (buffer-file-name))) ;; There is no file visiting the buffer, or the buffer has no ;; recorded last modification time, or there is no established @@ -1276,8 +1477,7 @@ of." (tramp-get-ls-command v) (tramp-shell-quote-argument localname))) (with-current-buffer (tramp-get-buffer v) - (setq attr (buffer-substring - (point) (progn (end-of-line) (point))))) + (setq attr (buffer-substring (point) (point-at-eol)))) (equal attr (tramp-get-file-property @@ -1289,6 +1489,7 @@ of." (defun tramp-sh-handle-set-file-modes (filename mode) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil + (tramp-flush-file-property v (file-name-directory localname)) (tramp-flush-file-property v localname) ;; FIXME: extract the proper text from chmod's stderr. (tramp-barf-unless-okay @@ -1300,31 +1501,39 @@ of." (defun tramp-sh-handle-set-file-times (filename &optional time) "Like `set-file-times' for Tramp files." - (if (file-remote-p filename) + (if (tramp-tramp-file-p filename) (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v localname) - (let ((time (if (or (null time) (equal time '(0 0))) - (current-time) - time)) - ;; With GNU Emacs, `format-time-string' has an optional - ;; parameter UNIVERSAL. This is preferred, because we - ;; could handle the case when the remote host is located - ;; in a different time zone as the local host. - (utc (not (featurep 'xemacs)))) - (tramp-send-command-and-check - v (format "%s touch -t %s %s" - (if utc "env TZ=UTC" "") - (if utc - (format-time-string "%Y%m%d%H%M.%S" time t) - (format-time-string "%Y%m%d%H%M.%S" time)) - (tramp-shell-quote-argument localname))))) + (when (tramp-get-remote-touch v) + (tramp-flush-file-property v (file-name-directory localname)) + (tramp-flush-file-property v localname) + (let ((time (if (or (null time) (equal time '(0 0))) + (current-time) + time)) + ;; With GNU Emacs, `format-time-string' has an + ;; optional parameter UNIVERSAL. This is preferred, + ;; because we could handle the case when the remote + ;; host is located in a different time zone as the + ;; local host. + (utc (not (featurep 'xemacs)))) + (tramp-send-command-and-check + v (format + "%s %s %s %s" + (if utc "env TZ=UTC" "") + (tramp-get-remote-touch v) + (if (tramp-get-connection-property v "touch-t" nil) + (format "-t %s" + (if utc + (format-time-string "%Y%m%d%H%M.%S" time t) + (format-time-string "%Y%m%d%H%M.%S" time))) + "") + (tramp-shell-quote-argument localname)))))) ;; We handle also the local part, because in older Emacsen, ;; without `set-file-times', this function is an alias for this. ;; We are local, so we don't need the UTC settings. (zerop (tramp-call-process - "touch" nil nil nil "-t" + nil "touch" nil nil nil "-t" (format-time-string "%Y%m%d%H%M.%S" time) (tramp-shell-quote-argument filename))))) @@ -1339,7 +1548,7 @@ be non-negative integers." ;; the majority of cases. ;; Don't modify `last-coding-system-used' by accident. (let ((last-coding-system-used last-coding-system-used)) - (if (file-remote-p filename) + (if (tramp-tramp-file-p filename) (with-parsed-tramp-file-name filename nil (if (and (zerop (user-uid)) (tramp-local-host-p v)) ;; If we are root on the local host, we can do it directly. @@ -1354,24 +1563,19 @@ be non-negative integers." (tramp-shell-quote-argument localname)))))) ;; We handle also the local part, because there doesn't exist - ;; `set-file-uid-gid'. On W32 "chown" might not work. - (let ((uid (or (and (natnump uid) uid) (tramp-get-local-uid 'integer))) - (gid (or (and (natnump gid) gid) (tramp-get-local-gid 'integer)))) - (tramp-call-process - "chown" nil nil nil - (format "%d:%d" uid gid) (tramp-shell-quote-argument filename)))))) + ;; `set-file-uid-gid'. On W32 "chown" might not work. We add a + ;; timeout for this. + (with-timeout (5 nil) + (let ((uid (or (and (natnump uid) uid) (tramp-get-local-uid 'integer))) + (gid (or (and (natnump gid) gid) (tramp-get-local-gid 'integer)))) + (tramp-call-process + nil "chown" nil nil nil + (format "%d:%d" uid gid) (tramp-shell-quote-argument filename))))))) (defun tramp-remote-selinux-p (vec) "Check, whether SELINUX is enabled on the remote host." - (with-tramp-connection-property - (tramp-get-connection-process vec) "selinux-p" - (let ((result (tramp-find-executable - vec "getenforce" (tramp-get-remote-path vec) t t))) - (and result - (string-equal - (tramp-send-command-and-read - vec (format "echo \\\"`%S`\\\"" result)) - "Enforcing"))))) + (with-tramp-connection-property (tramp-get-connection-process vec) "selinux-p" + (tramp-send-command-and-check vec "selinuxenabled"))) (defun tramp-sh-handle-file-selinux-context (filename) "Like `file-selinux-context' for Tramp files." @@ -1397,24 +1601,25 @@ be non-negative integers." (defun tramp-sh-handle-set-file-selinux-context (filename context) "Like `set-file-selinux-context' for Tramp files." (with-parsed-tramp-file-name filename nil - (if (and (consp context) - (tramp-remote-selinux-p v) - (tramp-send-command-and-check - v (format "chcon %s %s %s %s %s" - (if (stringp (nth 0 context)) - (format "--user=%s" (nth 0 context)) "") - (if (stringp (nth 1 context)) - (format "--role=%s" (nth 1 context)) "") - (if (stringp (nth 2 context)) - (format "--type=%s" (nth 2 context)) "") - (if (stringp (nth 3 context)) - (format "--range=%s" (nth 3 context)) "") - (tramp-shell-quote-argument localname)))) - (progn - (tramp-set-file-property v localname "file-selinux-context" context) - t) - (tramp-set-file-property v localname "file-selinux-context" 'undef) - nil))) + (when (and (consp context) + (tramp-remote-selinux-p v)) + (let ((user (and (stringp (nth 0 context)) (nth 0 context))) + (role (and (stringp (nth 1 context)) (nth 1 context))) + (type (and (stringp (nth 2 context)) (nth 2 context))) + (range (and (stringp (nth 3 context)) (nth 3 context)))) + (when (tramp-send-command-and-check + v (format "chcon %s %s %s %s %s" + (if user (format "--user=%s" user) "") + (if role (format "--role=%s" role) "") + (if type (format "--type=%s" type) "") + (if range (format "--range=%s" range) "") + (tramp-shell-quote-argument localname))) + (if (and user role type range) + (tramp-set-file-property + v localname "file-selinux-context" context) + (tramp-set-file-property + v localname "file-selinux-context" 'undef)) + t))))) (defun tramp-remote-acl-p (vec) "Check, whether ACL is enabled on the remote host." @@ -1428,7 +1633,7 @@ be non-negative integers." (when (and (tramp-remote-acl-p v) (tramp-send-command-and-check v (format - "getfacl -ac %s 2>/dev/null" + "getfacl -ac %s" (tramp-shell-quote-argument localname)))) (with-current-buffer (tramp-get-connection-buffer v) (goto-char (point-max)) @@ -1443,14 +1648,17 @@ be non-negative integers." (if (and (stringp acl-string) (tramp-remote-acl-p v) (progn (tramp-send-command - v (format "setfacl --set-file=- %s <<'EOF'\n%s\nEOF\n" - (tramp-shell-quote-argument localname) acl-string)) + v (format "setfacl --set-file=- %s <<'%s'\n%s\n%s\n" + (tramp-shell-quote-argument localname) + tramp-end-of-heredoc + acl-string + tramp-end-of-heredoc)) (tramp-send-command-and-check v nil))) ;; Success. (progn (tramp-set-file-property v localname "file-acl" acl-string) t) - ;; In case of errors, we return `nil'. + ;; In case of errors, we return nil. (tramp-set-file-property v localname "file-acl-string" 'undef) nil))) @@ -1517,7 +1725,7 @@ be non-negative integers." (defun tramp-sh-handle-file-directory-p (filename) "Like `file-directory-p' for Tramp files." (with-parsed-tramp-file-name filename nil - ;; `file-directory-p' is used as predicate for filename completion. + ;; `file-directory-p' is used as predicate for file name completion. ;; Sometimes, when a connection is not established yet, it is ;; desirable to return t immediately for "/method:foo:". It can ;; be expected that this is always a directory. @@ -1570,13 +1778,15 @@ be non-negative integers." (lambda (x) (cons (car x) (tramp-convert-file-attributes v (cdr x)))) - (cond - ((tramp-get-remote-stat v) - (tramp-do-directory-files-and-attributes-with-stat - v localname id-format)) - ((tramp-get-remote-perl v) - (tramp-do-directory-files-and-attributes-with-perl - v localname id-format))))))))) + (or + (cond + ((tramp-get-remote-stat v) + (tramp-do-directory-files-and-attributes-with-stat + v localname id-format)) + ((tramp-get-remote-perl v) + (tramp-do-directory-files-and-attributes-with-perl + v localname id-format)) + (t nil))))))))) result item) (while temp @@ -1586,9 +1796,12 @@ be non-negative integers." (setcar item (expand-file-name (car item) directory))) (push item result))) - (if nosort - result - (sort result (lambda (x y) (string< (car x) (car y)))))))) + (or (if nosort + result + (sort result (lambda (x y) (string< (car x) (car y))))) + ;; The scripts could fail, for example with huge file size. + (tramp-handle-directory-files-and-attributes + directory full match nosort id-format))))) (defun tramp-do-directory-files-and-attributes-with-perl (vec localname &optional id-format) @@ -1613,19 +1826,30 @@ be non-negative integers." vec (format (concat - ;; We must care about filenames with spaces, or starting with + ;; We must care about file names with spaces, or starting with ;; "-"; this would confuse xargs. "ls -aQ" might be a solution, - ;; but it does not work on all remote systems. Therefore, we - ;; quote the filenames via sed. - "cd %s; echo \"(\"; (%s -a | sed -e s/\\$/\\\"/g -e s/^/\\\"/g | " + ;; but it does not work on all remote systems. Apostrophes in + ;; the stat output are masked as `tramp-stat-marker', in order to + ;; make a proper shell escape of them in file names. + "cd %s && echo \"(\"; (%s %s -a | " "xargs %s -c " - "'(\"%%n\" (\"%%N\") %%h %s %s %%Xe0 %%Ye0 %%Ze0 %%se0 \"%%A\" t %%ie0 -1)'" - " 2>/dev/null); echo \")\"") + "'(%s%%n%s (%s%%N%s) %%h %s %s %%Xe0 %%Ye0 %%Ze0 %%se0 %s%%A%s t %%ie0 -1)' " + "-- 2>/dev/null | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'); echo \")\"") (tramp-shell-quote-argument localname) (tramp-get-ls-command vec) + ;; On systems which have no quoting style, file names with + ;; special characters could fail. + (if (tramp-get-ls-command-with-quoting-style vec) + "--quoting-style=shell" "") (tramp-get-remote-stat vec) - (if (eq id-format 'integer) "%ue0" "\"%U\"") - (if (eq id-format 'integer) "%ge0" "\"%G\"")))) + tramp-stat-marker tramp-stat-marker + tramp-stat-marker tramp-stat-marker + (if (eq id-format 'integer) + "%ue0" (concat tramp-stat-marker "%U" tramp-stat-marker)) + (if (eq id-format 'integer) + "%ge0" (concat tramp-stat-marker "%G" tramp-stat-marker)) + tramp-stat-marker tramp-stat-marker + tramp-stat-quoted-marker))) ;; This function should return "foo/" for directories and "bar" for ;; files. @@ -1639,15 +1863,15 @@ be non-negative integers." (mapcar 'list (or - ;; Try cache entries for filename, filename with last - ;; character removed, filename with last two characters + ;; Try cache entries for `filename', `filename' with last + ;; character removed, `filename' with last two characters ;; removed, ..., and finally the empty string - all ;; concatenated to the local directory name. (let ((remote-file-name-inhibit-cache (or remote-file-name-inhibit-cache tramp-completion-reread-directory-timeout))) - ;; This is inefficient for very long filenames, pity + ;; This is inefficient for very long file names, pity ;; `reduce' is not available... (car (apply @@ -1696,7 +1920,7 @@ be non-negative integers." 1 0))) (format (concat - "(\\cd %s 2>&1 && (%s %s -a 2>/dev/null" + "(cd %s 2>&1 && (%s -a %s 2>/dev/null" ;; `ls' with wildcard might fail with `Argument ;; list too long' error in some corner cases; if ;; `ls' fails after `cd' succeeded, chances are @@ -1704,14 +1928,14 @@ be non-negative integers." ;; wildcard. This will return "too many" entries ;; but that isn't harmful. " || %s -a 2>/dev/null)" - " | while read f; do" + " | while IFS= read f; do" " if %s -d \"$f\" 2>/dev/null;" " then \\echo \"$f/\"; else \\echo \"$f\"; fi; done" " && \\echo ok) || \\echo fail") (tramp-shell-quote-argument localname) (tramp-get-ls-command v) ;; When `filename' is empty, just `ls' without - ;; filename argument is more efficient than `ls *' + ;; `filename' argument is more efficient than `ls *' ;; for very large directories and might avoid the ;; `Argument list too long' error. ;; @@ -1720,7 +1944,7 @@ be non-negative integers." ;; sub-directories. (if (zerop (length filename)) "." - (concat (tramp-shell-quote-argument filename) "* -d")) + (format "-d %s*" (tramp-shell-quote-argument filename))) (tramp-get-ls-command v) (tramp-get-test-command v)))) @@ -1784,21 +2008,21 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" (with-parsed-tramp-file-name filename v1 (with-parsed-tramp-file-name newname v2 (let ((ln (when v1 (tramp-get-remote-ln v1)))) - (when (and (not ok-if-already-exists) + (when (and (numberp ok-if-already-exists) (file-exists-p newname) - (not (numberp ok-if-already-exists)) - (y-or-n-p + (yes-or-no-p (format "File %s already exists; make it a new name anyway? " newname))) (tramp-error - v2 'file-error - "add-name-to-file: file %s already exists" newname)) + v2 'file-error "add-name-to-file: file %s already exists" newname)) + (when ok-if-already-exists (setq ln (concat ln " -f"))) (tramp-flush-file-property v2 (file-name-directory v2-localname)) (tramp-flush-file-property v2 v2-localname) (tramp-barf-unless-okay v1 - (format "%s %s %s" ln (tramp-shell-quote-argument v1-localname) + (format "%s %s %s" ln + (tramp-shell-quote-argument v1-localname) (tramp-shell-quote-argument v2-localname)) "error with add-name-to-file, see buffer `%s' for details" (buffer-name)))))) @@ -1831,18 +2055,20 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" 'copy-file (list filename newname ok-if-already-exists keep-date))))) (defun tramp-sh-handle-copy-directory - (dirname newname &optional keep-date parents _copy-contents) + (dirname newname &optional keep-date parents copy-contents) "Like `copy-directory' for Tramp files." (let ((t1 (tramp-tramp-file-p dirname)) (t2 (tramp-tramp-file-p newname))) (with-parsed-tramp-file-name (if t1 dirname newname) nil - (if (and (tramp-get-method-parameter method 'tramp-copy-recursive) + (if (and (not copy-contents) + (tramp-get-method-parameter v 'tramp-copy-recursive) ;; When DIRNAME and NEWNAME are remote, they must have ;; the same method. (or (null t1) (null t2) (string-equal (tramp-file-name-method (tramp-dissect-file-name dirname)) - (tramp-file-name-method (tramp-dissect-file-name newname))))) + (tramp-file-name-method + (tramp-dissect-file-name newname))))) ;; scp or rsync DTRT. (progn (setq dirname (directory-file-name (expand-file-name dirname)) @@ -1859,7 +2085,10 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" 'copy dirname newname keep-date)) ;; We must do it file-wise. (tramp-run-real-handler - 'copy-directory (list dirname newname keep-date parents))) + 'copy-directory + (if copy-contents + (list dirname newname keep-date parents copy-contents) + (list dirname newname keep-date parents)))) ;; When newname did exist, we have wrong cached values. (when t2 @@ -1945,7 +2174,7 @@ file names." ;; create a new buffer, insert the contents of the ;; source file into it, then write out the buffer to ;; the target file. The advantage is that it doesn't - ;; matter which filename handlers are used for the + ;; matter which file name handlers are used for the ;; source and target file. (t (tramp-do-copy-or-rename-file-via-buffer @@ -1983,32 +2212,36 @@ file names." ;; In case of `rename', we must flush the cache of the source file. (when (and t1 (eq op 'rename)) (with-parsed-tramp-file-name filename v1 - (tramp-flush-file-property v1 (file-name-directory localname)) - (tramp-flush-file-property v1 localname))) + (tramp-flush-file-property v1 (file-name-directory v1-localname)) + (tramp-flush-file-property v1 v1-localname))) ;; When newname did exist, we have wrong cached values. (when t2 (with-parsed-tramp-file-name newname v2 - (tramp-flush-file-property v2 (file-name-directory localname)) - (tramp-flush-file-property v2 localname))))))) + (tramp-flush-file-property v2 (file-name-directory v2-localname)) + (tramp-flush-file-property v2 v2-localname))))))) (defun tramp-do-copy-or-rename-file-via-buffer (op filename newname keep-date) "Use an Emacs buffer to copy or rename a file. First arg OP is either `copy' or `rename' and indicates the operation. FILENAME is the source file, NEWNAME the target file. KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME." - (with-temp-buffer - ;; We must disable multibyte, because binary data shall not be - ;; converted. - (set-buffer-multibyte nil) - (let ((coding-system-for-read 'binary) - (jka-compr-inhibit t)) - (insert-file-contents-literally filename)) - ;; We don't want the target file to be compressed, so we let-bind - ;; `jka-compr-inhibit' to t. - (let ((coding-system-for-write 'binary) - (jka-compr-inhibit t)) - (write-region (point-min) (point-max) newname))) + ;; We must disable multibyte, because binary data shall not be + ;; converted. We don't want the target file to be compressed, so we + ;; let-bind `jka-compr-inhibit' to t. `epa-file-handler' shall not + ;; be called either. We remove `tramp-file-name-handler' from + ;; `inhibit-file-name-handlers'; otherwise the file name handler for + ;; `insert-file-contents' might be deactivated in some corner cases. + (let ((coding-system-for-read 'binary) + (coding-system-for-write 'binary) + (jka-compr-inhibit t) + (inhibit-file-name-operation 'write-region) + (inhibit-file-name-handlers + (cons 'epa-file-handler + (remq 'tramp-file-name-handler inhibit-file-name-handlers)))) + (with-temp-file newname + (set-buffer-multibyte nil) + (insert-file-contents-literally filename))) ;; KEEP-DATE handling. (when keep-date (set-file-times newname (nth 5 (file-attributes filename)))) ;; Set the mode. @@ -2077,6 +2310,12 @@ the uid and gid from FILENAME." ;; We can do it directly. ((let (file-name-handler-alist) (and (file-readable-p localname1) + ;; No sticky bit when renaming. + (or (eq op 'copy) + (zerop + (logand + (file-modes (file-name-directory localname1)) + (tramp-compat-octal-to-decimal "1000")))) (file-writable-p (file-name-directory localname2)) (or (file-directory-p localname2) (file-writable-p localname2)))) @@ -2170,19 +2409,19 @@ the uid and gid from FILENAME." (set-file-modes newname file-modes)))))) (defun tramp-do-copy-or-rename-file-out-of-band (op filename newname keep-date) - "Invoke rcp program to copy. + "Invoke `scp' program to copy. The method used must be an out-of-band method." (let* ((t1 (tramp-tramp-file-p filename)) (t2 (tramp-tramp-file-p newname)) (orig-vec (tramp-dissect-file-name (if t1 filename newname))) - copy-program copy-args copy-env copy-keep-date port spec - options source target) + copy-program copy-args copy-env copy-keep-date port listener spec + options source target remote-copy-program remote-copy-args) (with-parsed-tramp-file-name (if t1 filename newname) nil (if (and t1 t2) ;; Both are Tramp files. We shall optimize it when the - ;; methods for filename and newname are the same. + ;; methods for FILENAME and NEWNAME are the same. (let* ((dir-flag (file-directory-p filename)) (tmpfile (tramp-compat-make-temp-file localname dir-flag))) (if dir-flag @@ -2215,15 +2454,20 @@ The method used must be an out-of-band method." (aset v 3 localname) ;; Check which ones of source and target are Tramp files. - (setq source (if t1 (tramp-make-copy-program-file-name v) filename) - target (funcall + (setq source (if t1 + (tramp-make-copy-program-file-name v) + (shell-quote-argument filename)) + target (if t2 + (tramp-make-copy-program-file-name v) + (shell-quote-argument + (funcall (if (and (file-directory-p filename) (string-equal (file-name-nondirectory filename) (file-name-nondirectory newname))) 'file-name-directory 'identity) - (if t2 (tramp-make-copy-program-file-name v) newname))) + newname)))) ;; Check for host and port number. We cannot use ;; `tramp-file-name-port', because this returns also @@ -2239,6 +2483,13 @@ The method used must be an out-of-band method." (setq user (or (tramp-file-name-user v) (tramp-get-connection-property v "login-as" nil))) + ;; Check for listener port. + (when (tramp-get-method-parameter v 'tramp-remote-copy-args) + (setq listener (number-to-string (+ 50000 (random 10000)))) + (while + (zerop (tramp-call-process v "nc" nil nil nil "-z" host listener)) + (setq listener (number-to-string (+ 50000 (random 10000)))))) + ;; Compose copy command. (setq host (or host "") user (or user "") @@ -2246,17 +2497,14 @@ The method used must be an out-of-band method." spec (format-spec-make ?t (tramp-get-connection-property (tramp-get-connection-process v) "temp-file" "")) - options (format-spec - (if tramp-use-ssh-controlmaster-options - tramp-ssh-controlmaster-options "") - spec) + options (format-spec (tramp-ssh-controlmaster-options v) spec) spec (format-spec-make - ?h host ?u user ?p port ?c options + ?h host ?u user ?p port ?r listener ?c options ?k (if keep-date " " "")) - copy-program (tramp-get-method-parameter - method 'tramp-copy-program) + copy-program (tramp-get-method-parameter v 'tramp-copy-program) copy-keep-date (tramp-get-method-parameter - method 'tramp-copy-keep-date) + v 'tramp-copy-keep-date) + copy-args (delete ;; " " has either been a replacement of "%k" (when @@ -2264,14 +2512,13 @@ The method used must be an out-of-band method." ;; for the whole keep-date sublist. " " (dolist - (x - (tramp-get-method-parameter method 'tramp-copy-args) - copy-args) + (x (tramp-get-method-parameter v 'tramp-copy-args) copy-args) (setq copy-args (append copy-args (let ((y (mapcar (lambda (z) (format-spec z spec)) x))) (if (member "" y) '(" ") y)))))) + copy-env (delq nil @@ -2279,12 +2526,50 @@ The method used must be an out-of-band method." (lambda (x) (setq x (mapcar (lambda (y) (format-spec y spec)) x)) (unless (member "" x) (mapconcat 'identity x " "))) - (tramp-get-method-parameter method 'tramp-copy-env)))) + (tramp-get-method-parameter v 'tramp-copy-env))) + + remote-copy-program + (tramp-get-method-parameter v 'tramp-remote-copy-program)) + + (dolist (x (tramp-get-method-parameter v 'tramp-remote-copy-args)) + (setq remote-copy-args + (append + remote-copy-args + (let ((y (mapcar (lambda (z) (format-spec z spec)) x))) + (if (member "" y) '(" ") y))))) - ;; Check for program. + ;; Check for local copy program. (unless (executable-find copy-program) (tramp-error - v 'file-error "Cannot find copy program: %s" copy-program)) + v 'file-error "Cannot find local copy program: %s" copy-program)) + + ;; Install listener on the remote side. The prompt must be + ;; consumed later on, when the process does not listen anymore. + (when remote-copy-program + (unless (with-tramp-connection-property + v (concat "remote-copy-program-" remote-copy-program) + (tramp-find-executable + v remote-copy-program (tramp-get-remote-path v))) + (tramp-error + v 'file-error + "Cannot find remote listener: %s" remote-copy-program)) + (setq remote-copy-program + (mapconcat + 'identity + (append + (list remote-copy-program) remote-copy-args + (list (if t1 (concat "<" source) (concat ">" target)) "&")) + " ")) + (tramp-send-command v remote-copy-program) + (with-timeout + (60 (tramp-error + v 'file-error + "Listener process not running on remote host: `%s'" + remote-copy-program)) + (tramp-send-command v (format "netstat -l | grep -q :%s" listener)) + (while (not (tramp-send-command-and-check v nil)) + (tramp-send-command + v (format "netstat -l | grep -q :%s" listener))))) (with-temp-buffer (unwind-protect @@ -2301,31 +2586,37 @@ The method used must be an out-of-band method." (tramp-message orig-vec 6 "%s=\"%s\"" (car copy-env) (cadr copy-env)) (setenv (pop copy-env) (pop copy-env))) + (setq + copy-args + (append + copy-args + (if remote-copy-program + (list (if t1 (concat ">" target) (concat "<" source))) + (list source target)))) ;; Use an asynchronous process. By this, password can - ;; be handled. The default directory must be local, in - ;; order to apply the correct `copy-program'. We don't - ;; set a timeout, because the copying of large files can - ;; last longer than 60 secs. - (let ((p (let ((default-directory - (tramp-compat-temporary-file-directory))) - (apply 'start-process-shell-command - (tramp-get-connection-name v) - (tramp-get-connection-buffer v) - copy-program - (append - copy-args - (list - (shell-quote-argument source) - (shell-quote-argument target) - "&&" "echo" "tramp_exit_status" "0" - "||" "echo" "tramp_exit_status" "1")))))) + ;; be handled. We don't set a timeout, because the + ;; copying of large files can last longer than 60 + ;; secs. + (let ((p (apply 'start-process-shell-command + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + copy-program + (append + copy-args + (list "&&" "echo" "tramp_exit_status" "0" + "||" "echo" "tramp_exit_status" "1"))))) (tramp-message orig-vec 6 "%s" (mapconcat 'identity (process-command p) " ")) + (tramp-set-connection-property p "vector" orig-vec) (tramp-compat-set-process-query-on-exit-flag p nil) - (tramp-process-actions - p v nil tramp-actions-copy-out-of-band) + + ;; We must adapt `tramp-local-end-of-line' for + ;; sending the password. + (let ((tramp-local-end-of-line tramp-rsh-end-of-line)) + (tramp-process-actions + p v nil tramp-actions-copy-out-of-band)) ;; Check the return code. (goto-char (point-max)) @@ -2333,7 +2624,8 @@ The method used must be an out-of-band method." (re-search-backward "tramp_exit_status [0-9]+" nil t) (tramp-error orig-vec 'file-error - "Couldn't find exit status of `%s'" (process-command p))) + "Couldn't find exit status of `%s'" + (mapconcat 'identity (process-command p) " "))) (skip-chars-forward "^ ") (unless (zerop (read (current-buffer))) (forward-line -1) @@ -2343,9 +2635,15 @@ The method used must be an out-of-band method." (buffer-substring (point-min) (point-at-eol)))))) ;; Reset the transfer process properties. - (tramp-message orig-vec 6 "\n%s" (buffer-string)) (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil))) + (tramp-set-connection-property v "process-buffer" nil) + ;; Clear the remote prompt. + (when (and remote-copy-program + (not (tramp-send-command-and-check v nil))) + ;; Houston, we have a problem! Likely, the listener is + ;; still running, so let's clear everything (but the + ;; cached password). + (tramp-cleanup-connection v 'keep-debug 'keep-password)))) ;; Handle KEEP-DATE argument. (when (and keep-date (not copy-keep-date)) @@ -2381,7 +2679,7 @@ The method used must be an out-of-band method." (tramp-flush-file-property v (file-name-directory localname)) (tramp-flush-directory-property v localname) (tramp-barf-unless-okay - v (format "%s %s" + v (format "cd / && %s %s" (if recursive "rm -rf" "rmdir") (tramp-shell-quote-argument localname)) "Couldn't delete %s" directory))) @@ -2485,11 +2783,12 @@ This is like `dired-recursive-delete-directory' for Tramp files." (filename switches &optional wildcard full-directory-p) "Like `insert-directory' for Tramp files." (setq filename (expand-file-name filename)) + (unless switches (setq switches "")) (with-parsed-tramp-file-name filename nil (if (and (featurep 'ls-lisp) (not (symbol-value 'ls-lisp-use-insert-directory-program))) - (tramp-run-real-handler - 'insert-directory (list filename switches wildcard full-directory-p)) + (tramp-handle-insert-directory + filename switches wildcard full-directory-p) (when (stringp switches) (setq switches (split-string switches))) (when (and (member "--dired" switches) @@ -2500,8 +2799,8 @@ This is like `dired-recursive-delete-directory' for Tramp files." 'file-name-nondirectory (list localname))) (setq localname (tramp-run-real-handler 'file-name-directory (list localname)))) - (unless full-directory-p - (setq switches (add-to-list 'switches "-d" 'append))) + (unless (or full-directory-p (member "-d" switches)) + (setq switches (append switches '("-d")))) (setq switches (mapconcat 'tramp-shell-quote-argument switches " ")) (when wildcard (setq switches (concat switches " " wildcard))) @@ -2511,13 +2810,10 @@ This is like `dired-recursive-delete-directory' for Tramp files." (if full-directory-p "yes" "no")) ;; If `full-directory-p', we just say `ls -l FILENAME'. ;; Else we chdir to the parent directory, then say `ls -ld BASENAME'. - ;; "--dired" returns byte positions. Therefore, the file names - ;; must be encoded, which is guaranteed by "LC_ALL=en_US.utf8 - ;; LC_CTYPE=''". (if full-directory-p (tramp-send-command v - (format "env LC_ALL=en_US.utf8 LC_CTYPE='' %s %s %s 2>/dev/null" + (format "%s %s %s 2>/dev/null" (tramp-get-ls-command v) switches (if wildcard @@ -2533,7 +2829,7 @@ This is like `dired-recursive-delete-directory' for Tramp files." (tramp-run-real-handler 'file-name-directory (list localname)))) (tramp-send-command v - (format "env LC_ALL=en_US.utf8 LC_CTYPE='' %s %s %s 2>/dev/null" + (format "%s %s %s 2>/dev/null" (tramp-get-ls-command v) switches (if (or wildcard @@ -2544,69 +2840,73 @@ This is like `dired-recursive-delete-directory' for Tramp files." (tramp-shell-quote-argument (tramp-run-real-handler 'file-name-nondirectory (list localname))))))) - (let ((beg (point))) - ;; We cannot use `insert-buffer-substring' because the Tramp - ;; buffer changes its contents before insertion due to calling - ;; `expand-file' and alike. - (insert - (with-current-buffer (tramp-get-buffer v) - (buffer-string))) - - ;; Check for "--dired" output. - (forward-line -2) - (when (looking-at "//SUBDIRED//") - (forward-line -1)) - (when (looking-at "//DIRED//\\s-+") - (let ((databeg (match-end 0)) - (end (point-at-eol))) - ;; Now read the numeric positions of file names. - (goto-char databeg) - (while (< (point) end) - (let ((start (+ beg (read (current-buffer)))) - (end (+ beg (read (current-buffer))))) - (if (memq (char-after end) '(?\n ?\ )) - ;; End is followed by \n or by " -> ". - (put-text-property start end 'dired-filename t)))))) - ;; Remove trailing lines. - (goto-char (point-at-bol)) - (while (looking-at "//") - (forward-line 1) - (delete-region (match-beginning 0) (point))) - - ;; Some busyboxes are reluctant to discard colors. - (unless (string-match "color" (tramp-get-connection-property v "ls" "")) - (goto-char beg) - (while (re-search-forward tramp-color-escape-sequence-regexp nil t) - (replace-match ""))) - - ;; Decode the output, it could be multibyte. - (decode-coding-region - beg (point-max) - (or file-name-coding-system - (and (boundp 'default-file-name-coding-system) - (symbol-value 'default-file-name-coding-system)))) - - ;; The inserted file could be from somewhere else. - (when (and (not wildcard) (not full-directory-p)) - (goto-char (point-max)) - (when (file-symlink-p filename) - (goto-char (search-backward "->" beg 'noerror))) - (search-backward - (if (zerop (length (file-name-nondirectory filename))) - "." - (file-name-nondirectory filename)) - beg 'noerror) - (replace-match (file-relative-name filename) t)) - (goto-char (point-max)))))) + (save-restriction + (let ((beg (point))) + (narrow-to-region (point) (point)) + ;; We cannot use `insert-buffer-substring' because the Tramp + ;; buffer changes its contents before insertion due to calling + ;; `expand-file' and alike. + (insert + (with-current-buffer (tramp-get-buffer v) + (buffer-string))) + + ;; Check for "--dired" output. + (forward-line -2) + (when (looking-at "//SUBDIRED//") + (forward-line -1)) + (when (looking-at "//DIRED//\\s-+") + (let ((databeg (match-end 0)) + (end (point-at-eol))) + ;; Now read the numeric positions of file names. + (goto-char databeg) + (while (< (point) end) + (let ((start (+ beg (read (current-buffer)))) + (end (+ beg (read (current-buffer))))) + (if (memq (char-after end) '(?\n ?\ )) + ;; End is followed by \n or by " -> ". + (put-text-property start end 'dired-filename t)))))) + ;; Remove trailing lines. + (goto-char (point-at-bol)) + (while (looking-at "//") + (forward-line 1) + (delete-region (match-beginning 0) (point))) + + ;; Some busyboxes are reluctant to discard colors. + (unless + (string-match "color" (tramp-get-connection-property v "ls" "")) + (goto-char beg) + (while (re-search-forward tramp-color-escape-sequence-regexp nil t) + (replace-match ""))) + + ;; Decode the output, it could be multibyte. + (decode-coding-region + beg (point-max) + (or file-name-coding-system + (and (boundp 'default-file-name-coding-system) + (symbol-value 'default-file-name-coding-system)))) + + ;; The inserted file could be from somewhere else. + (when (and (not wildcard) (not full-directory-p)) + (goto-char (point-max)) + (when (file-symlink-p filename) + (goto-char (search-backward "->" beg 'noerror))) + (search-backward + (if (zerop (length (file-name-nondirectory filename))) + "." + (file-name-nondirectory filename)) + beg 'noerror) + (replace-match (file-relative-name filename) t)) + + (goto-char (point-max))))))) ;; Canonicalization of file names. (defun tramp-sh-handle-expand-file-name (name &optional dir) "Like `expand-file-name' for Tramp files. -If the localname part of the given filename starts with \"/../\" then -the result will be a local, non-Tramp, filename." - ;; If DIR is not given, use DEFAULT-DIRECTORY or "/". +If the localname part of the given file name starts with \"/../\" then +the result will be a local, non-Tramp, file name." + ;; If DIR is not given, use `default-directory' or "/". (setq dir (or dir default-directory "/")) ;; Unless NAME is absolute, concat DIR and NAME. (unless (file-name-absolute-p name) @@ -2637,7 +2937,7 @@ the result will be a local, non-Tramp, filename." (setq uname (with-tramp-connection-property v uname (tramp-send-command - v (format "cd %s; pwd" (tramp-shell-quote-argument uname))) + v (format "cd %s && pwd" (tramp-shell-quote-argument uname))) (with-current-buffer (tramp-get-buffer v) (goto-char (point-min)) (buffer-substring (point) (point-at-eol))))) @@ -2677,28 +2977,64 @@ the result will be a local, non-Tramp, filename." ;; connection has been setup. (defun tramp-sh-handle-start-file-process (name buffer program &rest args) "Like `start-file-process' for Tramp files." - (with-parsed-tramp-file-name default-directory nil - ;; When PROGRAM is nil, we just provide a tty. - (let ((command - (when (stringp program) - (format "cd %s; exec env PS1=%s %s" - (tramp-shell-quote-argument localname) - ;; 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 - (cons program args) " ")))) - (tramp-process-connection-type - (or (null program) tramp-process-connection-type)) - (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) - (name1 name) - (i 0) - ;; We do not want to raise an error when - ;; `start-file-process' has been started several time in - ;; `eshell' and friends. - (tramp-current-connection nil)) + (with-parsed-tramp-file-name (expand-file-name default-directory) nil + (let* (;; When PROGRAM matches "*sh", and the first arg is "-c", + ;; it might be that the arguments exceed the command line + ;; length. Therefore, we modify the command. + (heredoc (and (stringp program) + (string-match "sh$" program) + (string-equal "-c" (car args)) + (= (length args) 2))) + ;; When PROGRAM is nil, we just provide a tty. + (args (if (not heredoc) args + (let ((i 250)) + (while (and (< i (length (cadr args))) + (string-match " " (cadr args) i)) + (setcdr + args + (list (replace-match " \\\\\n" nil nil (cadr args)))) + (setq i (+ i 250)))) + (cdr args))) + ;; Use a human-friendly prompt, for example for `shell'. + ;; We discard hops, if existing, that's why we cannot use + ;; `file-remote-p'. + (prompt (format "PS1=%s %s" + (tramp-make-tramp-file-name + (tramp-file-name-method v) + (tramp-file-name-user v) + (tramp-file-name-host v) + (tramp-file-name-localname v)) + 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 %s %s" + (tramp-shell-quote-argument localname) + (if heredoc (format "<<'%s'" tramp-end-of-heredoc) "") + (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) + (mapconcat 'tramp-shell-quote-argument + (cons program args) " "))))) + (tramp-process-connection-type + (or (null program) tramp-process-connection-type)) + (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) + (name1 name) + (i 0) + ;; We do not want to raise an error when + ;; `start-file-process' has been started several times in + ;; `eshell' and friends. + (tramp-current-connection nil)) (unless buffer ;; BUFFER can be nil. We use a temporary buffer. @@ -2724,7 +3060,7 @@ the result will be a local, non-Tramp, filename." ;; `verify-visited-file-modtime'. (let ((buffer-undo-list t) (buffer-read-only nil) - (mark (point))) + (mark (point-max))) (clear-visited-file-modtime) (narrow-to-region (point-max) (point-max)) ;; We call `tramp-maybe-open-connection', in order @@ -2771,10 +3107,20 @@ the result will be a local, non-Tramp, filename." (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") @@ -2834,18 +3180,18 @@ the result will be a local, non-Tramp, filename." (unwind-protect (setq ret (if (tramp-send-command-and-check - v (format "\\cd %s; %s" + v (format "cd %s && %s" (tramp-shell-quote-argument localname) command) t t) 0 1)) - ;; We should show the output anyway. + ;; We should add the output anyway. (when outbuf (with-current-buffer outbuf (insert (with-current-buffer (tramp-get-connection-buffer v) (buffer-string)))) - (when display (display-buffer outbuf)))) + (when (and display (get-buffer-window outbuf t)) (redisplay)))) ;; When the user did interrupt, we should do it also. We use ;; return code -1 as marker. (quit @@ -2864,9 +3210,9 @@ the result will be a local, non-Tramp, filename." (when tmpinput (delete-file tmpinput)) ;; `process-file-side-effects' has been introduced with GNU - ;; Emacs 23.2. If set to `nil', no remote file will be changed + ;; Emacs 23.2. If set to nil, no remote file will be changed ;; by `program'. If it doesn't exist, we assume its default - ;; value `t'. + ;; value t. (unless (and (boundp 'process-file-side-effects) (not (symbol-value 'process-file-side-effects))) (tramp-flush-directory-property v "")) @@ -2901,28 +3247,27 @@ the result will be a local, non-Tramp, filename." (save-excursion (with-tramp-progress-reporter v 3 - (format "Encoding remote file `%s' with `%s'" filename rem-enc) + (format-message "Encoding remote file `%s' with `%s'" + filename rem-enc) (tramp-barf-unless-okay v (format rem-enc (tramp-shell-quote-argument localname)) "Encoding remote file failed")) (with-tramp-progress-reporter - v 3 (format "Decoding local file `%s' with `%s'" - tmpfile loc-dec) + v 3 (format-message "Decoding local file `%s' with `%s'" + tmpfile loc-dec) (if (functionp loc-dec) ;; If local decoding is a function, we call it. ;; We must disable multibyte, because ;; `uudecode-decode-region' doesn't handle it - ;; correctly. - (with-temp-buffer - (set-buffer-multibyte nil) - (insert-buffer-substring (tramp-get-buffer v)) - (funcall loc-dec (point-min) (point-max)) - ;; Unset `file-name-handler-alist'. Otherwise, - ;; epa-file gets confused. - (let (file-name-handler-alist - (coding-system-for-write 'binary)) - (write-region (point-min) (point-max) tmpfile))) + ;; correctly. Unset `file-name-handler-alist'. + ;; Otherwise, epa-file gets confused. + (let (file-name-handler-alist + (coding-system-for-write 'binary)) + (with-temp-file tmpfile + (set-buffer-multibyte nil) + (insert-buffer-substring (tramp-get-buffer v)) + (funcall loc-dec (point-min) (point-max)))) ;; If tramp-decoding-function is not defined for this ;; method, we invoke tramp-decoding-command instead. @@ -2932,7 +3277,8 @@ the result will be a local, non-Tramp, filename." (let (file-name-handler-alist (coding-system-for-write 'binary)) (with-current-buffer (tramp-get-buffer v) - (write-region (point-min) (point-max) tmpfile2))) + (write-region + (point-min) (point-max) tmpfile2 nil 'no-message))) (unwind-protect (tramp-call-local-coding-command loc-dec tmpfile2 tmpfile) @@ -2967,7 +3313,8 @@ the result will be a local, non-Tramp, filename." (if (fboundp 'find-buffer-file-type) (symbol-function 'find-buffer-file-type) nil)) - (inhibit-file-name-handlers '(jka-compr-handler image-file-handler)) + (inhibit-file-name-handlers + '(epa-file-handler image-file-handler jka-compr-handler)) (inhibit-file-name-operation 'insert-file-contents)) (unwind-protect (progn @@ -2978,48 +3325,6 @@ the result will be a local, non-Tramp, filename." (fset 'find-buffer-file-type find-buffer-file-type-function) (fmakunbound 'find-buffer-file-type))))) -(defun tramp-sh-handle-make-auto-save-file-name () - "Like `make-auto-save-file-name' for Tramp files. -Returns a file name in `tramp-auto-save-directory' for autosaving this file." - (let ((tramp-auto-save-directory tramp-auto-save-directory) - (buffer-file-name - (tramp-subst-strs-in-string - '(("_" . "|") - ("/" . "_a") - (":" . "_b") - ("|" . "__") - ("[" . "_l") - ("]" . "_r")) - (buffer-file-name)))) - ;; File name must be unique. This is ensured with Emacs 22 (see - ;; UNIQUIFY element of `auto-save-file-name-transforms'); but for - ;; all other cases we must do it ourselves. - (when (boundp 'auto-save-file-name-transforms) - (mapc - (lambda (x) - (when (and (string-match (car x) buffer-file-name) - (not (car (cddr x)))) - (setq tramp-auto-save-directory - (or tramp-auto-save-directory - (tramp-compat-temporary-file-directory))))) - (symbol-value 'auto-save-file-name-transforms))) - ;; Create directory. - (when tramp-auto-save-directory - (setq buffer-file-name - (expand-file-name buffer-file-name tramp-auto-save-directory)) - (unless (file-exists-p tramp-auto-save-directory) - (make-directory tramp-auto-save-directory t))) - ;; Run plain `make-auto-save-file-name'. There might be an advice when - ;; it is not a magic file name operation (since Emacs 22). - ;; We must deactivate it temporarily. - (if (not (ad-is-active 'make-auto-save-file-name)) - (tramp-run-real-handler 'make-auto-save-file-name nil) - ;; else - (ad-deactivate 'make-auto-save-file-name) - (prog1 - (tramp-run-real-handler 'make-auto-save-file-name nil) - (ad-activate 'make-auto-save-file-name))))) - ;; CCC grok LOCKNAME (defun tramp-sh-handle-write-region (start end filename &optional append visit lockname confirm) @@ -3106,7 +3411,7 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file." (symbol-value 'last-coding-system-used)))) ;; The permissions of the temporary file should be set. If - ;; filename does not exist (eq modes nil) it has been + ;; FILENAME does not exist (eq modes nil) it has been ;; renamed to the backup file. This case `save-buffer' ;; handles permissions. ;; Ensure that it is still readable. @@ -3117,7 +3422,7 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file." ;; This is a bit lengthy due to the different methods ;; possible for file transfer. First, we check whether the - ;; method uses an rcp program. If so, we call it. + ;; method uses an scp program. If so, we call it. ;; Otherwise, both encoding and decoding command must be ;; specified. However, if the method _also_ specifies an ;; encoding function, then that is used for encoding the @@ -3132,8 +3437,7 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file." (if (and (not (stringp start)) (= (or end (point-max)) (point-max)) (= (or start (point-min)) (point-min)) - (tramp-get-method-parameter - method 'tramp-copy-keep-tmpfile)) + (tramp-get-method-parameter v 'tramp-copy-keep-tmpfile)) (progn (setq tramp-temp-buffer-file-name tmpfile) (condition-case err @@ -3158,8 +3462,9 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file." (set-buffer-multibyte nil) ;; Use encoding function or command. (with-tramp-progress-reporter - v 3 (format "Encoding local file `%s' using `%s'" - tmpfile loc-enc) + v 3 (format-message + "Encoding local file `%s' using `%s'" + tmpfile loc-enc) (if (functionp loc-enc) ;; The following `let' is a workaround for ;; the base64.el that comes with pgnus-0.84. @@ -3188,16 +3493,19 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file." ;; writes to remote file. Because this happens on ;; the remote host, we cannot use the function. (with-tramp-progress-reporter - v 3 (format "Decoding remote file `%s' using `%s'" - filename rem-dec) + v 3 (format-message + "Decoding remote file `%s' using `%s'" + filename rem-dec) (goto-char (point-max)) (unless (bolp) (newline)) (tramp-send-command v (format - (concat rem-dec " <<'EOF'\n%sEOF") + (concat rem-dec " <<'%s'\n%s%s") (tramp-shell-quote-argument localname) - (buffer-string))) + tramp-end-of-heredoc + (buffer-string) + tramp-end-of-heredoc)) (tramp-barf-unless-okay v nil "Couldn't write region to `%s', decode using `%s' failed" @@ -3209,7 +3517,7 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file." (erase-buffer) (and ;; cksum runs locally, if possible. - (zerop (tramp-call-process "cksum" tmpfile t)) + (zerop (tramp-call-process v "cksum" tmpfile t)) ;; cksum runs remotely. (tramp-send-command-and-check v @@ -3235,7 +3543,7 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file." (tramp-error v 'file-error (concat "Method `%s' should specify both encoding and " - "decoding command or an rcp program") + "decoding command or an scp program") method)))) ;; Make `last-coding-system-used' have the right value. @@ -3252,7 +3560,7 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file." (when (or (eq visit t) (stringp visit)) (let ((file-attr (tramp-compat-file-attributes filename 'integer))) (set-visited-file-modtime - ;; We must pass modtime explicitly, because filename can + ;; We must pass modtime explicitly, because FILENAME can ;; be different from (buffer-file-name), f.e. if ;; `file-precious-flag' is set. (nth 5 file-attr)) @@ -3288,10 +3596,13 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file." (tramp-compat-with-temp-message "" (with-parsed-tramp-file-name file nil (with-tramp-progress-reporter - v 3 (format "Checking `vc-registered' for %s" file) + v 3 (format-message "Checking `vc-registered' for %s" file) ;; There could be new files, created by the vc backend. We - ;; cannot reuse the old cache entries, therefore. + ;; cannot reuse the old cache entries, therefore. In + ;; `tramp-get-file-property', `remote-file-name-inhibit-cache' + ;; could also be a timestamp as `current-time' returns. This + ;; means invalidate all cache entries with an older timestamp. (let (tramp-vc-registered-file-names (remote-file-name-inhibit-cache (current-time)) (file-name-handler-alist @@ -3312,22 +3623,53 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file." (dolist (elt - (tramp-send-command-and-read - v - (format - "tramp_vc_registered_read_file_names <<'EOF'\n%s\nEOF\n" - (mapconcat 'tramp-shell-quote-argument - tramp-vc-registered-file-names - "\n")))) + (ignore-errors + ;; We cannot use `tramp-send-command-and-read', + ;; because this does not cooperate well with + ;; heredoc documents. + (tramp-send-command + v + (format + "tramp_vc_registered_read_file_names <<'%s'\n%s\n%s\n" + tramp-end-of-heredoc + (mapconcat 'tramp-shell-quote-argument + tramp-vc-registered-file-names + "\n") + tramp-end-of-heredoc)) + (with-current-buffer (tramp-get-connection-buffer v) + ;; Read the expression. + (goto-char (point-min)) + (read (current-buffer))))) (tramp-set-file-property v (car elt) (cadr elt) (cadr (cdr elt)))))) ;; Second run. Now all `file-exists-p' or `file-readable-p' ;; calls shall be answered from the file cache. We unset - ;; `process-file-side-effects' in order to keep the cache when - ;; `process-file' calls appear. - (let (process-file-side-effects) + ;; `process-file-side-effects' and `remote-file-name-inhibit-cache' + ;; in order to keep the cache. + (let ((vc-handled-backends vc-handled-backends) + remote-file-name-inhibit-cache process-file-side-effects) + ;; Reduce `vc-handled-backends' in order to minimize process calls. + (when (and (memq 'Bzr vc-handled-backends) + (boundp 'vc-bzr-program) + (not (with-tramp-connection-property v vc-bzr-program + (tramp-find-executable + v vc-bzr-program (tramp-get-remote-path v))))) + (setq vc-handled-backends (remq 'Bzr vc-handled-backends))) + (when (and (memq 'Git vc-handled-backends) + (boundp 'vc-git-program) + (not (with-tramp-connection-property v vc-git-program + (tramp-find-executable + v vc-git-program (tramp-get-remote-path v))))) + (setq vc-handled-backends (remq 'Git vc-handled-backends))) + (when (and (memq 'Hg vc-handled-backends) + (boundp 'vc-hg-program) + (not (with-tramp-connection-property v vc-hg-program + (tramp-find-executable + v vc-hg-program (tramp-get-remote-path v))))) + (setq vc-handled-backends (remq 'Hg vc-handled-backends))) + ;; Run. (ignore-errors (tramp-run-real-handler 'vc-registered (list file)))))))) @@ -3337,17 +3679,18 @@ Returns a file name in `tramp-auto-save-directory' for autosaving this file." Fall back to normal file name handler if no Tramp handler exists." (when (and tramp-locked (not tramp-locker)) (setq tramp-locked nil) - (signal 'file-error (list "Forbidden reentrant call of Tramp"))) + (tramp-error + (car-safe tramp-current-connection) 'file-error + "Forbidden reentrant call of Tramp")) (let ((tl tramp-locked)) + (setq tramp-locked t) (unwind-protect - (progn - (setq tramp-locked t) - (let ((tramp-locker t)) - (save-match-data - (let ((fn (assoc operation tramp-sh-file-name-handler-alist))) - (if fn - (apply (cdr fn) args) - (tramp-run-real-handler operation args)))))) + (let ((tramp-locker t)) + (save-match-data + (let ((fn (assoc operation tramp-sh-file-name-handler-alist))) + (if fn + (apply (cdr fn) args) + (tramp-run-real-handler operation args))))) (setq tramp-locked tl)))) (defun tramp-vc-file-name-handler (operation &rest args) @@ -3380,42 +3723,70 @@ Fall back to normal file name handler if no Tramp handler exists." "Like `file-notify-add-watch' for Tramp files." (setq file-name (expand-file-name file-name)) (with-parsed-tramp-file-name file-name nil - (let* ((default-directory (file-name-directory file-name)) - command events filter p) + (let ((default-directory (file-name-directory file-name)) + command events filter p sequence) (cond ;; gvfs-monitor-dir. ((setq command (tramp-get-remote-gvfs-monitor-dir v)) - (setq filter 'tramp-sh-file-gvfs-monitor-dir-process-filter - p (start-file-process - "gvfs-monitor-dir" (generate-new-buffer " *gvfs-monitor-dir*") - command localname))) + (setq filter 'tramp-sh-gvfs-monitor-dir-process-filter + events + (cond + ((and (memq 'change flags) (memq 'attribute-change flags)) + '(created changed changes-done-hint moved deleted + attribute-changed)) + ((memq 'change flags) + '(created changed changes-done-hint moved deleted)) + ((memq 'attribute-change flags) '(attribute-changed))) + sequence `(,command ,localname))) ;; inotifywait. ((setq command (tramp-get-remote-inotifywait v)) - (setq filter 'tramp-sh-file-inotifywait-process-filter + (setq filter 'tramp-sh-inotifywait-process-filter events (cond ((and (memq 'change flags) (memq 'attribute-change flags)) - "create,modify,move,delete,attrib") - ((memq 'change flags) "create,modify,move,delete") - ((memq 'attribute-change flags) "attrib")) - p (start-file-process - "inotifywait" (generate-new-buffer " *inotifywait*") - command "-mq" "-e" events localname))) + (concat "create,modify,move,moved_from,moved_to,move_self," + "delete,delete_self,attrib,ignored")) + ((memq 'change flags) + (concat "create,modify,move,moved_from,moved_to,move_self," + "delete,delete_self,ignored")) + ((memq 'attribute-change flags) "attrib,ignored")) + sequence `(,command "-mq" "-e" ,events ,localname))) ;; None. (t (tramp-error v 'file-notify-error "No file notification program found on %s" (file-remote-p file-name)))) + ;; Start process. + (setq p (apply + 'start-file-process + (file-name-nondirectory command) + (generate-new-buffer + (format " *%s*" (file-name-nondirectory command))) + sequence)) ;; Return the process object as watch-descriptor. (if (not (processp p)) (tramp-error - v 'file-notify-error "`%s' failed to start on remote host" command) + v 'file-notify-error + "`%s' failed to start on remote host" + (mapconcat 'identity sequence " ")) + (tramp-message v 6 "Run `%s', %S" (mapconcat 'identity sequence " ") p) + (tramp-set-connection-property p "vector" v) + ;; Needed for `tramp-sh-gvfs-monitor-dir-process-filter'. + (tramp-compat-process-put p 'events events) + (tramp-compat-process-put p 'watch-name localname) (tramp-compat-set-process-query-on-exit-flag p nil) (set-process-filter p filter) + ;; There might be an error if the monitor is not supported. + ;; Give the filter a chance to read the output. + (tramp-accept-process-output p 1) + (unless (memq (process-status p) '(run open)) + (tramp-error + v 'file-notify-error "Monitoring not supported for `%s'" file-name)) p)))) -(defun tramp-sh-file-gvfs-monitor-dir-process-filter (proc string) - "Read output from \"gvfs-monitor-dir\" and add corresponding file-notify events." +(defun tramp-sh-gvfs-monitor-dir-process-filter (proc string) + "Read output from \"gvfs-monitor-dir\" and add corresponding \ +file-notify events." (let ((remote-prefix (with-current-buffer (process-buffer proc) (file-remote-p default-directory))) @@ -3425,8 +3796,10 @@ Fall back to normal file name handler if no Tramp handler exists." (tramp-message proc 6 "%S\n%s" proc string) (setq string (concat rest-string string) ;; Attribute change is returned in unused wording. - string (replace-regexp-in-string + string (tramp-compat-replace-regexp-in-string "ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string)) + (when (string-match "Monitoring not supported" string) + (delete-process proc)) (while (string-match (concat "^[\n\r]*" @@ -3435,29 +3808,36 @@ Fall back to normal file name handler if no Tramp handler exists." "\\(Other = \\([^\n\r]+\\)[\n\r]+\\)?" "Event = \\([^[:blank:]]+\\)[\n\r]+") string) - (let ((object - (list - proc - (intern-soft - (replace-regexp-in-string - "_" "-" (downcase (match-string 4 string)))) - ;; File names are returned as absolute paths. We must - ;; add the remote prefix. - (concat remote-prefix (match-string 1 string)) - (when (match-string 3 string) - (concat remote-prefix (match-string 3 string)))))) + (let* ((file (match-string 1 string)) + (file1 (match-string 3 string)) + (object + (list + proc + (intern-soft + (tramp-compat-replace-regexp-in-string + "_" "-" (downcase (match-string 4 string)))) + ;; File names are returned as absolute paths. We must + ;; add the remote prefix. + (concat remote-prefix file) + (when file1 (concat remote-prefix file1))))) (setq string (replace-match "" nil nil string)) + ;; Remove watch when file or directory to be watched is deleted. + (when (and (member (cadr object) '(moved deleted)) + (string-equal + file (tramp-compat-process-get proc 'watch-name))) + (delete-process proc)) ;; Usually, we would add an Emacs event now. Unfortunately, ;; `unread-command-events' does not accept several events at ;; once. Therefore, we apply the callback directly. - (tramp-compat-funcall 'file-notify-callback object))) + (when (member (cadr object) (tramp-compat-process-get proc 'events)) + (tramp-compat-funcall 'file-notify-callback object)))) ;; Save rest of the string. (when (zerop (length string)) (setq string nil)) (when string (tramp-message proc 10 "Rest string:\n%s" string)) (tramp-compat-process-put proc 'rest-string string))) -(defun tramp-sh-file-inotifywait-process-filter (proc string) +(defun tramp-sh-inotifywait-process-filter (proc string) "Read output from \"inotifywait\" and add corresponding file-notify events." (tramp-message proc 6 "%S\n%s" proc string) (dolist (line (split-string string "[\n\r]+" 'omit-nulls)) @@ -3475,9 +3855,13 @@ Fall back to normal file name handler if no Tramp handler exists." proc (mapcar (lambda (x) - (intern-soft (replace-regexp-in-string "_" "-" (downcase x)))) + (intern-soft + (tramp-compat-replace-regexp-in-string "_" "-" (downcase x)))) (split-string (match-string 1 line) "," 'omit-nulls)) (match-string 3 line)))) + ;; Remove watch when file or directory to be watched is deleted. + (when (equal (cadr object) 'ignored) + (delete-process proc)) ;; Usually, we would add an Emacs event now. Unfortunately, ;; `unread-command-events' does not accept several events at ;; once. Therefore, we apply the callback directly. @@ -3493,30 +3877,24 @@ Only send the definition if it has not already been done." (let ((scripts (tramp-get-connection-property (tramp-get-connection-process vec) "scripts" nil))) (unless (member name scripts) - (with-tramp-progress-reporter vec 5 (format "Sending script `%s'" name) + (with-tramp-progress-reporter + vec 5 (format-message "Sending script `%s'" name) + ;; In bash, leading TABs like in `tramp-vc-registered-read-file-names' + ;; could result in unwanted command expansion. Avoid this. + (setq script (tramp-compat-replace-regexp-in-string + (make-string 1 ?\t) (make-string 8 ? ) script)) ;; The script could contain a call of Perl. This is masked with `%s'. (when (and (string-match "%s" script) (not (tramp-get-remote-perl vec))) (tramp-error vec 'file-error "No Perl available on remote host")) (tramp-barf-unless-okay vec - (format "%s () {\n%s\n}" name - (format script (tramp-get-remote-perl vec))) + (format "%s () {\n%s\n}" + name (format script (tramp-get-remote-perl vec))) "Script %s sending failed" name) (tramp-set-connection-property (tramp-get-connection-process vec) "scripts" (cons name scripts)))))) -(defun tramp-set-auto-save () - (when (and ;; ange-ftp has its own auto-save mechanism - (eq (tramp-find-foreign-file-name-handler (buffer-file-name)) - 'tramp-sh-file-name-handler) - auto-save-default) - (auto-save-mode 1))) -(add-hook 'find-file-hooks 'tramp-set-auto-save t) -(add-hook 'tramp-unload-hook - (lambda () - (remove-hook 'find-file-hooks 'tramp-set-auto-save))) - (defun tramp-run-test (switch filename) "Run `test' on the remote system, given a SWITCH and a FILENAME. Returns the exit code of the `test' program." @@ -3563,8 +3941,13 @@ This function expects to be in the right *tramp* buffer." (let (result) ;; Check whether the executable is in $PATH. "which(1)" does not ;; report always a correct error code; therefore we check the - ;; number of words it returns. - (unless ignore-path + ;; number of words it returns. "SunOS 5.10" (and maybe "SunOS + ;; 5.11") have problems with this command, we disable the call + ;; therefore. + (unless (or ignore-path + (string-match + (regexp-opt '("SunOS 5.10" "SunOS 5.11")) + (tramp-get-connection-property vec "uname" ""))) (tramp-send-command vec (format "which \\%s | wc -w" progname)) (goto-char (point-min)) (if (looking-at "^\\s-*1$") @@ -3583,11 +3966,14 @@ This function expects to be in the right *tramp* buffer." (tramp-send-command vec (format (concat "while read d; " - "do if test -x $d/%s -a -f $d/%s; " + "do if test -x $d/%s && test -f $d/%s; " "then echo tramp_executable $d/%s; " - "break; fi; done <<'EOF'\n" - "%s\nEOF") - progname progname progname (mapconcat 'identity dirlist "\n"))) + "break; fi; done <<'%s'\n" + "%s\n%s") + progname progname progname + tramp-end-of-heredoc + (mapconcat 'identity dirlist "\n") + tramp-end-of-heredoc)) (goto-char (point-max)) (when (search-backward "tramp_executable " nil t) (skip-chars-forward "^ ") @@ -3666,39 +4052,46 @@ file exists and nonzero exit status otherwise." (defun tramp-open-shell (vec shell) "Opens shell SHELL." (with-tramp-progress-reporter - vec 5 (format "Opening remote shell `%s'" shell) + vec 5 (format-message "Opening remote shell `%s'" shell) ;; Find arguments for this shell. - (let ((tramp-end-of-output tramp-initial-end-of-output) - (alist tramp-sh-extra-args) + (let ((alist tramp-sh-extra-args) item extra-args) (while (and alist (null extra-args)) (setq item (pop alist)) (when (string-match (car item) shell) (setq extra-args (cdr item)))) + ;; It is useful to set the prompt in the following command + ;; because some people have a setting for $PS1 which /bin/sh + ;; doesn't know about and thus /bin/sh will display a strange + ;; prompt. For example, if $PS1 has "${CWD}" in the value, then + ;; ksh will display the current working directory but /bin/sh + ;; will display a dollar sign. The following command line sets + ;; $PS1 to a sane value, and works under Bourne-ish shells as + ;; well as csh-like shells. We also unset the variable $ENV + ;; because that is read by some sh implementations (eg, bash + ;; when called as sh) on startup; this way, we avoid the startup + ;; file clobbering $PS1. $PROMPT_COMMAND is another way to set + ;; the prompt in /bin/bash, it must be discarded as well. + ;; $HISTFILE is set according to `tramp-histfile-override'. (tramp-send-command vec (format - "exec env ENV='' PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s" + "exec env ENV='' %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s" + (if (stringp tramp-histfile-override) + (format "HISTFILE=%s" + (tramp-shell-quote-argument tramp-histfile-override)) + (if tramp-histfile-override + "HISTFILE='' HISTFILESIZE=0 HISTSIZE=0" + "")) (tramp-shell-quote-argument tramp-end-of-output) shell (or extra-args "")) t)) (tramp-set-connection-property - (tramp-get-connection-process vec) "remote-shell" shell) - ;; Setting prompts. - (tramp-send-command - vec (format "PS1=%s" (tramp-shell-quote-argument tramp-end-of-output)) t) - (tramp-send-command vec "PS2=''" t) - (tramp-send-command vec "PS3=''" t) - (tramp-send-command vec "PROMPT_COMMAND=''" t))) + (tramp-get-connection-process vec) "remote-shell" shell))) (defun tramp-find-shell (vec) "Opens a shell on the remote host which groks tilde expansion." (with-current-buffer (tramp-get-buffer vec) - (let ((default-shell - (or - (tramp-get-connection-property - (tramp-get-connection-process vec) "remote-shell" nil) - (tramp-get-method-parameter - (tramp-file-name-method vec) 'tramp-remote-shell))) + (let ((default-shell (tramp-get-method-parameter vec 'tramp-remote-shell)) shell) (setq shell (with-tramp-connection-property vec "remote-shell" @@ -3757,29 +4150,12 @@ seconds. If not, it produces an error message with the given ERROR-ARGS." Mainly sets the prompt and the echo correctly. PROC is the shell process to set up. VEC specifies the connection." (let ((tramp-end-of-output tramp-initial-end-of-output)) - ;; It is useful to set the prompt in the following command because - ;; some people have a setting for $PS1 which /bin/sh doesn't know - ;; about and thus /bin/sh will display a strange prompt. For - ;; example, if $PS1 has "${CWD}" in the value, then ksh will - ;; display the current working directory but /bin/sh will display - ;; a dollar sign. The following command line sets $PS1 to a sane - ;; value, and works under Bourne-ish shells as well as csh-like - ;; shells. Daniel Pittman reports that the unusual positioning of - ;; the single quotes makes it work under `rc', too. We also unset - ;; the variable $ENV because that is read by some sh - ;; implementations (eg, bash when called as sh) on startup; this - ;; way, we avoid the startup file clobbering $PS1. $PROMPT_COMMAND - ;; is another way to set the prompt in /bin/bash, it must be - ;; discarded as well. - (tramp-open-shell - vec - (or (tramp-get-connection-property vec "remote-shell" nil) - (tramp-get-method-parameter - (tramp-file-name-method vec) 'tramp-remote-shell))) + (tramp-open-shell vec (tramp-get-method-parameter vec 'tramp-remote-shell)) - ;; Disable echo. + ;; Disable tab and echo expansion. (tramp-message vec 5 "Setting up remote shell environment") - (tramp-send-command vec "stty -inlcr -echo kill '^U' erase '^H'" t) + (tramp-send-command + vec "stty tab0 -inlcr -onlcr -echo kill '^U' erase '^H'" t) ;; Check whether the echo has really been disabled. Some ;; implementations, like busybox of embedded GNU/Linux, don't ;; support disabling. @@ -3795,23 +4171,22 @@ process to set up. VEC specifies the connection." (tramp-message vec 5 "Setting shell prompt") (tramp-send-command - vec (format "PS1=%s" (tramp-shell-quote-argument tramp-end-of-output)) t) - (tramp-send-command vec "PS2=''" t) - (tramp-send-command vec "PS3=''" t) - (tramp-send-command vec "PROMPT_COMMAND=''" t) + vec (format "PS1=%s PS2='' PS3='' PROMPT_COMMAND=''" + (tramp-shell-quote-argument tramp-end-of-output)) t) ;; Try to set up the coding system correctly. ;; CCC this can't be the right way to do it. Hm. (tramp-message vec 5 "Determining coding system") - (tramp-send-command vec "echo foo ; echo bar" t) (with-current-buffer (process-buffer proc) - (goto-char (point-min)) (if (featurep 'mule) ;; Use MULE to select the right EOL convention for communicating ;; with the process. - (let* ((cs (or (tramp-compat-funcall 'process-coding-system proc) - (cons 'undecided 'undecided))) - cs-decode cs-encode) + (let ((cs (or (and (memq 'utf-8 (coding-system-list)) + (string-match "utf8" (tramp-get-remote-locale vec)) + (cons 'utf-8 'utf-8)) + (tramp-compat-funcall 'process-coding-system proc) + (cons 'undecided 'undecided))) + cs-decode cs-encode) (when (symbolp cs) (setq cs (cons cs cs))) (setq cs-decode (car cs)) (setq cs-encode (cdr cs)) @@ -3819,6 +4194,8 @@ process to set up. VEC specifies the connection." (unless cs-encode (setq cs-encode 'undecided)) (setq cs-encode (tramp-compat-coding-system-change-eol-conversion cs-encode 'unix)) + (tramp-send-command vec "echo foo ; echo bar" t) + (goto-char (point-min)) (when (search-forward "\r" nil t) (setq cs-decode (tramp-compat-coding-system-change-eol-conversion cs-decode 'dos))) @@ -3846,11 +4223,12 @@ process to set up. VEC specifies the connection." vec "uname" (tramp-send-command-and-read vec "echo \\\"`uname -sr`\\\"")))) (when (and (stringp old-uname) (not (string-equal old-uname new-uname))) - (tramp-cleanup vec) (tramp-message vec 3 "Connection reset, because remote host changed from `%s' to `%s'" old-uname new-uname) + ;; We want to keep the password. + (tramp-cleanup-connection vec t t) (throw 'uname-changed (tramp-maybe-open-connection vec)))) ;; Check whether the remote host suffers from buggy @@ -3911,16 +4289,24 @@ process to set up. VEC specifies the connection." ;; Set the environment. (tramp-message vec 5 "Setting default environment") - (let ((env (copy-sequence tramp-remote-process-environment)) - unset item) + (let ((env (append `(,(tramp-get-remote-locale vec)) + (copy-sequence tramp-remote-process-environment))) + unset vars item) (while env (setq item (tramp-compat-split-string (car env) "=")) (setcdr item (mapconcat 'identity (cdr item) "=")) (if (and (stringp (cdr item)) (not (string-equal (cdr item) ""))) - (tramp-send-command - vec (format "%s=%s; export %s" (car item) (cdr item) (car item)) t) + (push (format "%s %s" (car item) (cdr item)) vars) (push (car item) unset)) (setq env (cdr env))) + (when vars + (tramp-send-command + vec + (format "while read var val; do export $var=$val; done <<'%s'\n%s\n%s" + tramp-end-of-heredoc + (mapconcat 'identity vars "\n") + tramp-end-of-heredoc) + t)) (when unset (tramp-send-command vec (format "unset %s" (mapconcat 'identity unset " ")) t)))) @@ -3947,7 +4333,7 @@ process to set up. VEC specifies the connection." "List of local coding commands for inline transfer. Each item is a list that looks like this: -\(FORMAT ENCODING DECODING\) +\(FORMAT ENCODING DECODING) FORMAT is symbol describing the encoding/decoding format. It can be `b64' for base64 encoding, `uu' for uu encoding, or `pack' for simple packing. @@ -3955,7 +4341,7 @@ FORMAT is symbol describing the encoding/decoding format. It can be ENCODING and DECODING can be strings, giving commands, or symbols, giving functions. If they are strings, then they can contain the \"%s\" format specifier. If that specifier is present, the input -filename will be put into the command line at that spot. If the +file name will be put into the command line at that spot. If the specifier is not present, the input should be read from standard input. @@ -3964,16 +4350,19 @@ and end of region, and are expected to replace the region contents with the encoded or decoded results, respectively.") (defconst tramp-remote-coding-commands - '((b64 "base64" "base64 -d -i") + `((b64 "base64" "base64 -d -i") ;; "-i" is more robust with older base64 from GNU coreutils. ;; However, I don't know whether all base64 versions do supports ;; this option. (b64 "base64" "base64 -d") + (b64 "openssl enc -base64" "openssl enc -d -base64") (b64 "mimencode -b" "mimencode -u -b") (b64 "mmencode -b" "mmencode -u -b") (b64 "recode data..base64" "recode base64..data") (b64 tramp-perl-encode-with-module tramp-perl-decode-with-module) (b64 tramp-perl-encode tramp-perl-decode) + ;; This is painful slow, so we put it on the end. + (b64 tramp-awk-encode tramp-awk-decode ,tramp-awk-coding-test) (uu "uuencode xxx" "uudecode -o /dev/stdout" "test -c /dev/stdout") (uu "uuencode xxx" "uudecode -o -") (uu "uuencode xxx" "uudecode -p") @@ -3982,21 +4371,23 @@ with the encoded or decoded results, respectively.") "List of remote coding commands for inline transfer. Each item is a list that looks like this: -\(FORMAT ENCODING DECODING [TEST]\) +\(FORMAT ENCODING DECODING [TEST]) -FORMAT is symbol describing the encoding/decoding format. It can be +FORMAT is a symbol describing the encoding/decoding format. It can be `b64' for base64 encoding, `uu' for uu encoding, or `pack' for simple packing. ENCODING and DECODING can be strings, giving commands, or symbols, giving variables. If they are strings, then they can contain the \"%s\" format specifier. If that specifier is present, the input -filename will be put into the command line at that spot. If the +file name will be put into the command line at that spot. If the specifier is not present, the input should be read from standard input. -If they are variables, this variable is a string containing a Perl -implementation for this functionality. This Perl program will be transferred -to the remote host, and it is available as shell function with the same name. +If they are variables, this variable is a string containing a +Perl or Shell implementation for this functionality. This +program will be transferred to the remote host, and it is +available as shell function with the same name. A \"%t\" format +specifier in the variable value denotes a temporary file. The optional TEST command can be used for further tests, whether ENCODING and DECODING are applicable.") @@ -4049,6 +4440,11 @@ Goes through the list `tramp-local-coding-commands' and vec 5 "Checking remote test command `%s'" rem-test) (unless (tramp-send-command-and-check vec rem-test t) (throw 'wont-work-remote nil))) + ;; Check if remote perl exists when necessary. + (when (and (symbolp rem-enc) + (string-match "perl" (symbol-name rem-enc)) + (not (tramp-get-remote-perl vec))) + (throw 'wont-work-remote nil)) ;; Check if remote encoding and decoding commands can be ;; called remotely with null input and output. This makes ;; sure there are no syntax errors and the command is really @@ -4071,10 +4467,25 @@ Goes through the list `tramp-local-coding-commands' and (throw 'wont-work-remote nil)) (when (not (stringp rem-dec)) - (let ((name (symbol-name rem-dec))) + (let ((name (symbol-name rem-dec)) + (value (symbol-value rem-dec)) + tmpfile) (while (string-match (regexp-quote "-") name) (setq name (replace-match "_" nil t name))) - (tramp-maybe-send-script vec (symbol-value rem-dec) name) + (when (string-match "\\(^\\|[^%]\\)%t" value) + (setq tmpfile + (make-temp-name + (expand-file-name + tramp-temp-name-prefix + (tramp-get-remote-tmpdir vec))) + value + (format-spec + value + (format-spec-make + ?t + (tramp-file-name-handler + 'file-remote-p tmpfile 'localname))))) + (tramp-maybe-send-script vec value name) (setq rem-dec name))) (tramp-message vec 5 @@ -4095,32 +4506,28 @@ Goes through the list `tramp-local-coding-commands' and (setq rem-dec (nth 2 ritem)) (setq found t))))))) - ;; Did we find something? - (unless found - (tramp-error - vec 'file-error "Couldn't find an inline transfer encoding")) - - ;; Set connection properties. Since the commands are risky (due - ;; to output direction), we cache them in the process cache. - (tramp-message vec 5 "Using local encoding `%s'" loc-enc) - (tramp-set-connection-property p "local-encoding" loc-enc) - (tramp-message vec 5 "Using local decoding `%s'" loc-dec) - (tramp-set-connection-property p "local-decoding" loc-dec) - (tramp-message vec 5 "Using remote encoding `%s'" rem-enc) - (tramp-set-connection-property p "remote-encoding" rem-enc) - (tramp-message vec 5 "Using remote decoding `%s'" rem-dec) - (tramp-set-connection-property p "remote-decoding" rem-dec)))) + (when found + ;; Set connection properties. Since the commands are risky + ;; (due to output direction), we cache them in the process cache. + (tramp-message vec 5 "Using local encoding `%s'" loc-enc) + (tramp-set-connection-property p "local-encoding" loc-enc) + (tramp-message vec 5 "Using local decoding `%s'" loc-dec) + (tramp-set-connection-property p "local-decoding" loc-dec) + (tramp-message vec 5 "Using remote encoding `%s'" rem-enc) + (tramp-set-connection-property p "remote-encoding" rem-enc) + (tramp-message vec 5 "Using remote decoding `%s'" rem-dec) + (tramp-set-connection-property p "remote-decoding" rem-dec))))) (defun tramp-call-local-coding-command (cmd input output) "Call the local encoding or decoding command. If CMD contains \"%s\", provide input file INPUT there in command. Otherwise, INPUT is passed via standard input. INPUT can also be nil which means `/dev/null'. -OUTPUT can be a string (which specifies a filename), or t (which +OUTPUT can be a string (which specifies a file name), or t (which means standard output and thus the current buffer), or nil (which means discard it)." (tramp-call-process - tramp-encoding-shell + nil tramp-encoding-shell (when (and input (not (string-match "%s" cmd))) input) (if (eq output t) t nil) nil @@ -4137,7 +4544,7 @@ means discard it)." "List of compress and decompress commands for inline transfer. Each item is a list that looks like this: -\(COMPRESS DECOMPRESS\) +\(COMPRESS DECOMPRESS) COMPRESS or DECOMPRESS are strings with the respective commands.") @@ -4252,7 +4659,7 @@ Gateway hops are already opened." ?h (or (tramp-file-name-host (car target-alist)) "")))) (with-parsed-tramp-file-name proxy l ;; Add the hop. - (add-to-list 'target-alist l) + (push l target-alist) ;; Start next search. (setq choices tramp-default-proxies-alist))))) @@ -4270,29 +4677,24 @@ Gateway hops are already opened." vec 'file-error "Connection `%s' is not supported for gateway access." hop)) ;; Open the gateway connection. - (add-to-list - 'target-alist + (push (vector (tramp-file-name-method hop) (tramp-file-name-user hop) - (tramp-compat-funcall 'tramp-gw-open-connection vec gw hop) nil nil)) + (tramp-compat-funcall 'tramp-gw-open-connection vec gw hop) nil nil) + target-alist) ;; For the password prompt, we need the correct values. ;; Therefore, we must remember the gateway vector. But we ;; cannot do it as connection property, because it shouldn't ;; be persistent. And we have no started process yet either. - (tramp-set-file-property (car target-alist) "" "gateway" hop))) + (let ((tramp-verbose 0)) + (tramp-set-file-property (car target-alist) "" "gateway" hop)))) ;; Foreign and out-of-band methods are not supported for multi-hops. (when (cdr target-alist) (setq choices target-alist) - (while choices - (setq item (pop choices)) - (when - (or - (not - (tramp-get-method-parameter - (tramp-file-name-method item) 'tramp-login-program)) - (tramp-get-method-parameter - (tramp-file-name-method item) 'tramp-copy-program)) + (while (setq item (pop choices)) + (when (or (not (tramp-get-method-parameter item 'tramp-login-program)) + (tramp-get-method-parameter item 'tramp-copy-program)) (tramp-error vec 'file-error "Method `%s' is not supported for multi-hops." @@ -4300,7 +4702,7 @@ Gateway hops are already opened." ;; In case the host name is not used for the remote shell ;; command, the user could be misguided by applying a random - ;; hostname. + ;; host name. (let* ((v (car target-alist)) (method (tramp-file-name-method v)) (host (tramp-file-name-host v))) @@ -4309,8 +4711,7 @@ Gateway hops are already opened." ;; There are multi-hops. (cdr target-alist) ;; The host name is used for the remote shell command. - (member - '("%h") (tramp-get-method-parameter method 'tramp-login-args)) + (member '("%h") (tramp-get-method-parameter v 'tramp-login-args)) ;; The host is local. We cannot use `tramp-local-host-p' ;; here, because it opens a connection as well. (string-match tramp-local-host-regexp host)) @@ -4322,84 +4723,130 @@ Gateway hops are already opened." ;; Result. target-alist)) +(defun tramp-ssh-controlmaster-options (vec) + "Return the Control* arguments of the local ssh." + (cond + ;; No options to be computed. + ((or (null tramp-use-ssh-controlmaster-options) + (null (assoc "%c" (tramp-get-method-parameter vec 'tramp-login-args)))) + "") + + ;; There is already a value to be used. + ((stringp tramp-ssh-controlmaster-options) tramp-ssh-controlmaster-options) + + ;; Determine the options. + (t (setq tramp-ssh-controlmaster-options "") + (let ((case-fold-search t)) + (ignore-errors + (when (executable-find "ssh") + (with-temp-buffer + (tramp-call-process vec "ssh" nil t nil "-o" "ControlMaster") + (goto-char (point-min)) + (when (search-forward-regexp "missing.+argument" nil t) + (setq tramp-ssh-controlmaster-options "-o ControlMaster=auto"))) + (unless (zerop (length tramp-ssh-controlmaster-options)) + (with-temp-buffer + ;; We use a non-existing IP address, in order to avoid + ;; useless connections, and DNS timeouts. + (tramp-call-process + vec "ssh" nil t nil "-o" "ControlPath=%C" "0.0.0.1") + (goto-char (point-min)) + (setq tramp-ssh-controlmaster-options + (concat tramp-ssh-controlmaster-options + (if (search-forward-regexp "unknown.+key" nil t) + " -o ControlPath='tramp.%%r@%%h:%%p'" + " -o ControlPath='tramp.%%C'")))) + (with-temp-buffer + (tramp-call-process vec "ssh" nil t nil "-o" "ControlPersist") + (goto-char (point-min)) + (when (search-forward-regexp "missing.+argument" nil t) + (setq tramp-ssh-controlmaster-options + (concat tramp-ssh-controlmaster-options + " -o ControlPersist=no")))))))) + tramp-ssh-controlmaster-options))) + (defun tramp-maybe-open-connection (vec) "Maybe open a connection VEC. Does not do anything if a connection is already open, but re-opens the connection if a previous connection has died for some reason." - (catch 'uname-changed - (let ((p (tramp-get-connection-process vec)) - (process-name (tramp-get-connection-property vec "process-name" nil)) - (process-environment (copy-sequence process-environment)) - (pos (with-current-buffer (tramp-get-connection-buffer vec) (point)))) - - ;; If Tramp opens the same connection within a short time frame, - ;; there is a problem. We shall signal this. - (unless (or (and p (processp p) (memq (process-status p) '(run open))) - (not (equal (butlast (append vec nil) 2) - (car tramp-current-connection))) - (> (tramp-time-diff - (current-time) (cdr tramp-current-connection)) - (or tramp-connection-min-time-diff 0))) - (throw 'suppress 'suppress)) - - ;; If too much time has passed since last command was sent, look - ;; whether process is still alive. If it isn't, kill it. When - ;; using ssh, it can sometimes happen that the remote end has - ;; hung up but the local ssh client doesn't recognize this until - ;; it tries to send some data to the remote end. So that's why - ;; we try to send a command from time to time, then look again - ;; whether the process is really alive. - (condition-case nil - (when (and (> (tramp-time-diff - (current-time) - (tramp-get-connection-property - p "last-cmd-time" '(0 0 0))) - 60) - p (processp p) (memq (process-status p) '(run open))) - (tramp-send-command vec "echo are you awake" t t) - (unless (and (memq (process-status p) '(run open)) - (tramp-wait-for-output p 10)) - ;; The error will be caught locally. - (tramp-error vec 'file-error "Awake did fail"))) - (file-error - (tramp-cleanup vec) - (setq p nil))) - - ;; New connection must be opened. - (condition-case err - (unless (and p (processp p) (memq (process-status p) '(run open))) - - ;; We call `tramp-get-buffer' in order to get a debug - ;; buffer for messages from the beginning. - (tramp-get-buffer vec) - - ;; If `non-essential' is non-nil, don't reopen a new connection. - (when (and (boundp 'non-essential) (symbol-value 'non-essential)) - (throw 'non-essential 'non-essential)) - - (with-tramp-progress-reporter - vec 3 - (if (zerop (length (tramp-file-name-user vec))) - (format "Opening connection for %s using %s" - (tramp-file-name-host vec) - (tramp-file-name-method vec)) - (format "Opening connection for %s@%s using %s" - (tramp-file-name-user vec) + (tramp-check-proper-method-and-host vec) + + (let ((p (tramp-get-connection-process vec)) + (process-name (tramp-get-connection-property vec "process-name" nil)) + (process-environment (copy-sequence process-environment)) + (pos (with-current-buffer (tramp-get-connection-buffer vec) (point)))) + + ;; If Tramp opens the same connection within a short time frame, + ;; there is a problem. We shall signal this. + (unless (or (and p (processp p) (memq (process-status p) '(run open))) + (not (equal (butlast (append vec nil) 2) + (car tramp-current-connection))) + (> (tramp-time-diff + (current-time) (cdr tramp-current-connection)) + (or tramp-connection-min-time-diff 0))) + (throw 'suppress 'suppress)) + + ;; If too much time has passed since last command was sent, look + ;; whether process is still alive. If it isn't, kill it. When + ;; using ssh, it can sometimes happen that the remote end has hung + ;; up but the local ssh client doesn't recognize this until it + ;; tries to send some data to the remote end. So that's why we + ;; try to send a command from time to time, then look again + ;; whether the process is really alive. + (condition-case nil + (when (and (> (tramp-time-diff + (current-time) + (tramp-get-connection-property + p "last-cmd-time" '(0 0 0))) + 60) + p (processp p) (memq (process-status p) '(run open))) + (tramp-send-command vec "echo are you awake" t t) + (unless (and (memq (process-status p) '(run open)) + (tramp-wait-for-output p 10)) + ;; The error will be caught locally. + (tramp-error vec 'file-error "Awake did fail"))) + (file-error + (tramp-cleanup-connection vec t) + (setq p nil))) + + ;; New connection must be opened. + (condition-case err + (unless (and p (processp p) (memq (process-status p) '(run open))) + + ;; If `non-essential' is non-nil, don't reopen a new connection. + (when (and (boundp 'non-essential) (symbol-value 'non-essential)) + (throw 'non-essential 'non-essential)) + + (with-tramp-progress-reporter + vec 3 + (if (zerop (length (tramp-file-name-user vec))) + (format "Opening connection for %s using %s" (tramp-file-name-host vec) - (tramp-file-name-method vec))) + (tramp-file-name-method vec)) + (format "Opening connection for %s@%s using %s" + (tramp-file-name-user vec) + (tramp-file-name-host vec) + (tramp-file-name-method vec))) + (catch 'uname-changed ;; Start new process. (when (and p (processp p)) (delete-process p)) (setenv "TERM" tramp-terminal-type) - (setenv "LC_ALL" "C") + (setenv "LC_ALL" "en_US.utf8") + (if (stringp tramp-histfile-override) + (setenv "HISTFILE" tramp-histfile-override) + (if tramp-histfile-override + (progn + (setenv "HISTFILE") + (setenv "HISTFILESIZE" "0") + (setenv "HISTSIZE" "0")))) (setenv "PROMPT_COMMAND") (setenv "PS1" tramp-initial-end-of-output) (let* ((target-alist (tramp-compute-multi-hops vec)) ;; We will apply `tramp-ssh-controlmaster-options' ;; only for the first hop. - (options (if tramp-use-ssh-controlmaster-options - tramp-ssh-controlmaster-options "")) + (options (tramp-ssh-controlmaster-options vec)) (process-connection-type tramp-process-connection-type) (process-adaptive-read-buffering nil) (coding-system-for-read nil) @@ -4440,20 +4887,20 @@ connection if a previous connection has died for some reason." (l-host (tramp-file-name-host hop)) (l-port nil) (login-program - (tramp-get-method-parameter - l-method 'tramp-login-program)) + (tramp-get-method-parameter hop 'tramp-login-program)) (login-args - (tramp-get-method-parameter - l-method 'tramp-login-args)) + (tramp-get-method-parameter hop 'tramp-login-args)) + (login-env + (tramp-get-method-parameter hop 'tramp-login-env)) (async-args - (tramp-get-method-parameter - l-method 'tramp-async-args)) + (tramp-get-method-parameter hop 'tramp-async-args)) (connection-timeout (tramp-get-method-parameter - l-method 'tramp-connection-timeout)) + hop 'tramp-connection-timeout)) (gw-args - (tramp-get-method-parameter l-method 'tramp-gw-args)) - (gw (tramp-get-file-property hop "" "gateway" nil)) + (tramp-get-method-parameter hop 'tramp-gw-args)) + (gw (let ((tramp-verbose 0)) + (tramp-get-file-property hop "" "gateway" nil))) (g-method (and gw (tramp-file-name-method gw))) (g-user (and gw (tramp-file-name-user gw))) (g-host (and gw (tramp-file-name-real-host gw))) @@ -4481,8 +4928,10 @@ connection if a previous connection has died for some reason." (setq login-args (append async-args login-args))) ;; Add gateway arguments if necessary. - (when (and gw gw-args) - (setq login-args (append gw-args login-args))) + (when gw + (tramp-set-connection-property p "gateway" t) + (when gw-args + (setq login-args (append gw-args login-args)))) ;; Check for port number. Until now, there's no ;; need for handling like method, user, host. @@ -4502,7 +4951,25 @@ connection if a previous connection has died for some reason." tramp-current-user (or g-user l-user) tramp-current-host (or g-host l-host)) - ;; Replace login-args place holders. + ;; Add login environment. + (when login-env + (setq + login-env + (mapcar + (lambda (x) + (setq x (mapcar (lambda (y) (format-spec y spec)) x)) + (unless (member "" x) (mapconcat 'identity x " "))) + login-env)) + (while login-env + (setq command + (format + "%s=%s %s" + (pop login-env) + (tramp-shell-quote-argument (pop login-env)) + command))) + (setq command (concat "env " command))) + + ;; Replace `login-args' place holders. (setq l-host (or l-host "") l-user (or l-user "") @@ -4542,13 +5009,13 @@ connection if a previous connection has died for some reason." target-alist (cdr target-alist))) ;; Make initial shell settings. - (tramp-open-connection-setup-interactive-shell p vec)))) + (tramp-open-connection-setup-interactive-shell p vec))))) - ;; When the user did interrupt, we must cleanup. - (quit - (tramp-cleanup vec) - ;; Propagate the quit signal. - (signal (car err) (cdr err))))))) + ;; When the user did interrupt, we must cleanup. + (quit + (tramp-cleanup-connection vec t) + ;; Propagate the quit signal. + (signal (car err) (cdr err)))))) (defun tramp-send-command (vec command &optional neveropen nooutput) "Send the COMMAND to connection VEC. @@ -4561,15 +5028,18 @@ function waits for output unless NOOUTPUT is set." (when (tramp-get-connection-property p "remote-echo" nil) ;; We mark the command string that it can be erased in the output buffer. (tramp-set-connection-property p "check-remote-echo" t) + ;; If we put `tramp-echo-mark' after a trailing newline (which + ;; is assumed to be unquoted) `tramp-send-string' doesn't see + ;; that newline and adds `tramp-rsh-end-of-line' right after + ;; `tramp-echo-mark', so the remote shell sees two consecutive + ;; trailing line endings and sends two prompts after executing + ;; the command, which confuses `tramp-wait-for-output'. + (when (and (not (string= command "")) + (string-equal (substring command -1) "\n")) + (setq command (substring command 0 -1))) + ;; No need to restore a trailing newline here since `tramp-send-string' + ;; makes sure that the string ends in `tramp-rsh-end-of-line', anyway. (setq command (format "%s%s%s" tramp-echo-mark command tramp-echo-mark))) - ;; Some busyboxes tend to close the connection when we use the - ;; following syntax for here-documents. This we cannot test; it - ;; shall be set via `tramp-connection-properties'. - (when (and (string-match "<<'EOF'" command) - (not (tramp-get-connection-property vec "busybox" nil))) - ;; Unset $PS1 when using here documents, in order to avoid - ;; multiple prompts. - (setq command (concat "(PS1= ; " command "\n)"))) ;; Send the command. (tramp-message vec 6 "%s" command) (tramp-send-string vec command) @@ -4615,8 +5085,9 @@ function waits for output unless NOOUTPUT is set." (defun tramp-send-command-and-check (vec command &optional subshell dont-suppress-err) "Run COMMAND and check its exit status. -Sends `echo $?' along with the COMMAND for checking the exit status. If -COMMAND is nil, just sends `echo $?'. Returns the exit status found. +Sends `echo $?' along with the COMMAND for checking the exit status. +If COMMAND is nil, just sends `echo $?'. Returns t if the exit +status is 0, and nil otherwise. If the optional argument SUBSHELL is non-nil, the command is executed in a subshell, ie surrounded by parentheses. If @@ -4646,8 +5117,9 @@ FMT and ARGS which are passed to `error'." (or (tramp-send-command-and-check vec command) (apply 'tramp-error vec 'file-error fmt args))) -(defun tramp-send-command-and-read (vec command &optional noerror) +(defun tramp-send-command-and-read (vec command &optional noerror marker) "Run COMMAND and return the output, which must be a Lisp expression. +If MARKER is a regexp, read the output after that string. In case there is no valid Lisp expression and NOERROR is nil, it raises an error." (when (if noerror @@ -4655,8 +5127,17 @@ raises an error." (tramp-barf-unless-okay vec command "`%s' returns with error" command)) (with-current-buffer (tramp-get-connection-buffer vec) - ;; Read the expression. (goto-char (point-min)) + ;; Read the marker. + (when (stringp marker) + (condition-case nil + (re-search-forward marker) + (error (unless noerror + (tramp-error + vec 'file-error + "`%s' does not return the marker `%s': `%s'" + command marker (buffer-string)))))) + ;; Read the expression. (condition-case nil (prog1 (read (current-buffer)) ;; Error handling. @@ -4755,20 +5236,27 @@ Return ATTR." "")) (defun tramp-make-copy-program-file-name (vec) - "Create a file name suitable to be passed to `rcp' and workalikes." - (let ((user (tramp-file-name-user vec)) + "Create a file name suitable for `scp', `pscp', or `nc' and workalikes." + (let ((method (tramp-file-name-method vec)) + (user (tramp-file-name-user vec)) (host (tramp-file-name-real-host vec)) - (localname (tramp-shell-quote-argument - (tramp-file-name-localname vec)))) - (if (not (zerop (length user))) - (format "%s@%s:%s" user host localname) - (format "%s:%s" host localname)))) + (localname (tramp-file-name-localname vec))) + (when (string-match tramp-ipv6-regexp host) + (setq host (format "[%s]" host))) + (unless (string-match "ftp$" method) + (setq localname (tramp-shell-quote-argument localname))) + (cond + ((tramp-get-method-parameter vec 'tramp-remote-copy-program) + localname) + ((not (zerop (length user))) + (shell-quote-argument (format "%s@%s:%s" user host localname))) + (t (shell-quote-argument (format "%s:%s" host localname)))))) (defun tramp-method-out-of-band-p (vec size) "Return t if this is an out-of-band method, nil otherwise." (and ;; It shall be an out-of-band method. - (tramp-get-method-parameter (tramp-file-name-method vec) 'tramp-copy-program) + (tramp-get-method-parameter vec 'tramp-copy-program) ;; There must be a size, otherwise the file doesn't exist. (numberp size) ;; Either the file size is large enough, or (in rare cases) there @@ -4804,19 +5292,30 @@ Return ATTR." "/bin:/usr/bin") "/bin:/usr/bin")))) (own-remote-path - (when elt2 - (condition-case nil - (tramp-send-command-and-read vec "echo \\\"$PATH\\\"") - (error - (tramp-message - vec 3 "$PATH not set, ignoring `tramp-own-remote-path'.") - nil))))) + ;; The login shell could return more than just the $PATH + ;; string. So we use `tramp-end-of-heredoc' as marker. + (when elt2 + (tramp-send-command-and-read + vec + (format + "%s %s %s 'echo %s \\\"$PATH\\\"'" + (tramp-get-method-parameter vec 'tramp-remote-shell) + (mapconcat + 'identity + (tramp-get-method-parameter vec 'tramp-remote-shell-login) + " ") + (mapconcat + 'identity + (tramp-get-method-parameter vec 'tramp-remote-shell-args) + " ") + (tramp-shell-quote-argument tramp-end-of-heredoc)) + nil (regexp-quote tramp-end-of-heredoc))))) ;; Replace place holder `tramp-default-remote-path'. (when elt1 (setcdr elt1 (append - (tramp-compat-split-string default-remote-path ":") + (tramp-compat-split-string (or default-remote-path "") ":") (cdr elt1))) (setq remote-path (delq 'tramp-default-remote-path remote-path))) @@ -4824,7 +5323,7 @@ Return ATTR." (when elt2 (setcdr elt2 (append - (tramp-compat-split-string own-remote-path ":") + (tramp-compat-split-string (or own-remote-path "") ":") (cdr elt2))) (setq remote-path (delq 'tramp-own-remote-path remote-path))) @@ -4851,6 +5350,22 @@ Return ATTR." x)) remote-path))))) +(defun tramp-get-remote-locale (vec) + (with-tramp-connection-property vec "locale" + (tramp-send-command vec "locale -a") + (let ((candidates '("en_US.utf8" "C.utf8")) + locale) + (with-current-buffer (tramp-get-connection-buffer vec) + (while candidates + (goto-char (point-min)) + (if (string-match (format "^%s\r?$" (regexp-quote (car candidates))) + (buffer-string)) + (setq locale (car candidates) + candidates nil) + (setq candidates (cdr candidates))))) + ;; Return value. + (format "LC_ALL=%s" (or locale "C"))))) + (defun tramp-get-ls-command (vec) (with-tramp-connection-property vec "ls" (tramp-message vec 5 "Finding a suitable `ls' command") @@ -4886,6 +5401,17 @@ Return ATTR." (tramp-send-command-and-check vec (format "%s --dired -al /dev/null" (tramp-get-ls-command vec)))))) +(defun tramp-get-ls-command-with-quoting-style (vec) + (save-match-data + (with-tramp-connection-property vec "ls-quoting-style" + (tramp-message vec 5 "Checking, whether `ls --quoting-style=shell' works") + ;; Some "ls" versions are sensible wrt the order of arguments, + ;; they fail when "-al" is after the "--dired" argument (for + ;; example on FreeBSD). + (tramp-send-command-and-check + vec (format "%s --quoting-style=shell -al /dev/null" + (tramp-get-ls-command vec)))))) + (defun tramp-get-test-command (vec) (with-tramp-connection-property vec "test" (tramp-message vec 5 "Finding a suitable `test' command") @@ -4974,6 +5500,30 @@ Return ATTR." (tramp-message vec 5 "Finding a suitable `trash' command") (tramp-find-executable vec "trash" (tramp-get-remote-path vec)))) +(defun tramp-get-remote-touch (vec) + (with-tramp-connection-property vec "touch" + (tramp-message vec 5 "Finding a suitable `touch' command") + (let ((result (tramp-find-executable + vec "touch" (tramp-get-remote-path vec))) + (tmpfile + (make-temp-name + (expand-file-name + tramp-temp-name-prefix (tramp-get-remote-tmpdir vec))))) + ;; Busyboxes do support the "-t" option only when they have been + ;; built with the DESKTOP config option. Let's check it. + (when result + (tramp-set-connection-property + vec "touch-t" + (tramp-send-command-and-check + vec + (format + "%s -t %s %s" + result + (format-time-string "%Y%m%d%H%M.%S") + (tramp-file-name-handler 'file-remote-p tmpfile 'localname)))) + (delete-file tmpfile)) + result))) + (defun tramp-get-remote-gvfs-monitor-dir (vec) (with-tramp-connection-property vec "gvfs-monitor-dir" (tramp-message vec 5 "Finding a suitable `gvfs-monitor-dir' command") @@ -4988,40 +5538,110 @@ Return ATTR." (defun tramp-get-remote-id (vec) (with-tramp-connection-property vec "id" (tramp-message vec 5 "Finding POSIX `id' command") - (or - (catch 'id-found - (let ((dl (tramp-get-remote-path vec)) - result) - (while (and dl (setq result (tramp-find-executable vec "id" dl t t))) - ;; Check POSIX parameter. - (when (tramp-send-command-and-check vec (format "%s -u" result)) - (throw 'id-found result)) - (setq dl (cdr dl))))) - (tramp-error vec 'file-error "Couldn't find a POSIX `id' command")))) + (catch 'id-found + (dolist (cmd '("id" "gid")) + (let ((dl (tramp-get-remote-path vec)) + result) + (while (and dl (setq result (tramp-find-executable vec cmd dl t t))) + ;; Check POSIX parameter. + (when (tramp-send-command-and-check vec (format "%s -u" result)) + (throw 'id-found result)) + (setq dl (cdr dl)))))))) + +(defun tramp-get-remote-uid-with-id (vec id-format) + (tramp-send-command-and-read + vec + (format "%s -u%s %s" + (tramp-get-remote-id vec) + (if (equal id-format 'integer) "" "n") + (if (equal id-format 'integer) + "" "| sed -e s/^/\\\"/ -e s/\\$/\\\"/")))) + +(defun tramp-get-remote-uid-with-perl (vec id-format) + (tramp-send-command-and-read + vec + (format "%s -le '%s'" + (tramp-get-remote-perl vec) + (if (equal id-format 'integer) + "print $>" + "print \"\\\"\", scalar getpwuid($>), \"\\\"\"")))) + +(defun tramp-get-remote-python (vec) + (with-tramp-connection-property vec "python" + (tramp-message vec 5 "Finding a suitable `python' command") + (or (tramp-find-executable vec "python" (tramp-get-remote-path vec)) + (tramp-find-executable vec "python2" (tramp-get-remote-path vec)) + (tramp-find-executable vec "python3" (tramp-get-remote-path vec))))) + +(defun tramp-get-remote-uid-with-python (vec id-format) + (tramp-send-command-and-read + vec + (format "%s -c \"%s\"" + (tramp-get-remote-python vec) + (if (equal id-format 'integer) + "import os; print (os.getuid())" + "import os, pwd; print ('\\\"' + pwd.getpwuid(os.getuid())[0] + '\\\"')")))) (defun tramp-get-remote-uid (vec id-format) (with-tramp-connection-property vec (format "uid-%s" id-format) - (let ((res (tramp-send-command-and-read - vec - (format "%s -u%s %s" - (tramp-get-remote-id vec) - (if (equal id-format 'integer) "" "n") - (if (equal id-format 'integer) - "" "| sed -e s/^/\\\"/ -e s/\$/\\\"/"))))) - ;; The command might not always return a number. - (if (and (equal id-format 'integer) (not (integerp res))) -1 res)))) + (let ((res + (ignore-errors + (cond + ((tramp-get-remote-id vec) + (tramp-get-remote-uid-with-id vec id-format)) + ((tramp-get-remote-perl vec) + (tramp-get-remote-uid-with-perl vec id-format)) + ((tramp-get-remote-python vec) + (tramp-get-remote-uid-with-python vec id-format)))))) + ;; Ensure there is a valid result. + (cond + ((and (equal id-format 'integer) (not (integerp res))) -1) + ((and (equal id-format 'string) (not (stringp res))) "UNKNOWN") + (t res))))) + +(defun tramp-get-remote-gid-with-id (vec id-format) + (tramp-send-command-and-read + vec + (format "%s -g%s %s" + (tramp-get-remote-id vec) + (if (equal id-format 'integer) "" "n") + (if (equal id-format 'integer) + "" "| sed -e s/^/\\\"/ -e s/\\$/\\\"/")))) + +(defun tramp-get-remote-gid-with-perl (vec id-format) + (tramp-send-command-and-read + vec + (format "%s -le '%s'" + (tramp-get-remote-perl vec) + (if (equal id-format 'integer) + "print ($)=~/(\\d+)/)" + "print \"\\\"\", scalar getgrgid($)), \"\\\"\"")))) + +(defun tramp-get-remote-gid-with-python (vec id-format) + (tramp-send-command-and-read + vec + (format "%s -c \"%s\"" + (tramp-get-remote-python vec) + (if (equal id-format 'integer) + "import os; print (os.getgid())" + "import os, grp; print ('\\\"' + grp.getgrgid(os.getgid())[0] + '\\\"')")))) (defun tramp-get-remote-gid (vec id-format) (with-tramp-connection-property vec (format "gid-%s" id-format) - (let ((res (tramp-send-command-and-read - vec - (format "%s -g%s %s" - (tramp-get-remote-id vec) - (if (equal id-format 'integer) "" "n") - (if (equal id-format 'integer) - "" "| sed -e s/^/\\\"/ -e s/\$/\\\"/"))))) - ;; The command might not always return a number. - (if (and (equal id-format 'integer) (not (integerp res))) -1 res)))) + (let ((res + (ignore-errors + (cond + ((tramp-get-remote-id vec) + (tramp-get-remote-gid-with-id vec id-format)) + ((tramp-get-remote-perl vec) + (tramp-get-remote-gid-with-perl vec id-format)) + ((tramp-get-remote-python vec) + (tramp-get-remote-gid-with-python vec id-format)))))) + ;; Ensure there is a valid result. + (cond + ((and (equal id-format 'integer) (not (integerp res))) -1) + ((and (equal id-format 'string) (not (stringp res))) "UNKNOWN") + (t res))))) ;; Some predefined connection properties. (defun tramp-get-inline-compress (vec prop size) @@ -5049,7 +5669,7 @@ If no corresponding command is found, nil is returned. Otherwise, either a string is returned which contains a `%s' mark to be used for the respective input or output file; or a Lisp function cell is returned to be applied on a buffer." - ;; We must catch the errors, because we want to return `nil', when + ;; We must catch the errors, because we want to return nil, when ;; no inline coding is found. (ignore-errors (let ((coding @@ -5079,16 +5699,20 @@ function cell is returned to be applied on a buffer." `(lambda (beg end) (,coding beg end) (let ((coding-system-for-write 'binary) - (coding-system-for-read 'binary)) + (coding-system-for-read 'binary) + (default-directory + (tramp-compat-temporary-file-directory))) (apply - 'call-process-region (point-min) (point-max) + 'tramp-call-process-region ,vec (point-min) (point-max) (car (split-string ,compress)) t t nil (cdr (split-string ,compress))))) `(lambda (beg end) (let ((coding-system-for-write 'binary) - (coding-system-for-read 'binary)) + (coding-system-for-read 'binary) + (default-directory + (tramp-compat-temporary-file-directory))) (apply - 'call-process-region beg end + 'tramp-call-process-region ,vec beg end (car (split-string ,compress)) t t nil (cdr (split-string ,compress)))) (,coding (point-min) (point-max))))) @@ -5134,8 +5758,6 @@ function cell is returned to be applied on a buffer." ;; * Don't use globbing for directories with many files, as this is ;; likely to produce long command lines, and some shells choke on ;; long command lines. -;; * Make it work for different encodings, and for different file name -;; encodings, too. (Daniel Pittman) ;; * Don't search for perl5 and perl. Instead, only search for perl and ;; then look if it's the right version (with `perl -v'). ;; * When editing a remote CVS controlled file as a different user, VC @@ -5181,7 +5803,5 @@ function cell is returned to be applied on a buffer." ;; rsync). ;; * Keep a second connection open for out-of-band methods like scp or ;; rsync. -;; * Try telnet+curl as new method. It might be useful for busybox, -;; without built-in uuencode/uudecode. ;;; tramp-sh.el ends here diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 39e87f994c2..c95679584dc 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -1,6 +1,6 @@ ;;; tramp-smb.el --- Tramp access functions for SMB servers -;; Copyright (C) 2002-2013 Free Software Foundation, Inc. +;; Copyright (C) 2002-2015 Free Software Foundation, Inc. ;; Author: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes @@ -70,11 +70,20 @@ tramp-smb-method '((tramp-parse-netrc "~/.netrc")))) +;;;###tramp-autoload (defcustom tramp-smb-program "smbclient" "Name of SMB client to run." :group 'tramp :type 'string) +;;;###tramp-autoload +(defcustom tramp-smb-acl-program "smbcacls" + "Name of SMB acls to run." + :group 'tramp + :type 'string + :version "24.4") + +;;;###tramp-autoload (defcustom tramp-smb-conf "/dev/null" "Path of the smb.conf file. If it is nil, no smb.conf will be added to the `tramp-smb-program' @@ -129,11 +138,14 @@ call, letting the SMB client use the default one." "NT_STATUS_DIRECTORY_NOT_EMPTY" "NT_STATUS_DUPLICATE_NAME" "NT_STATUS_FILE_IS_A_DIRECTORY" + "NT_STATUS_HOST_UNREACHABLE" "NT_STATUS_IMAGE_ALREADY_LOADED" + "NT_STATUS_INVALID_LEVEL" "NT_STATUS_IO_TIMEOUT" "NT_STATUS_LOGON_FAILURE" "NT_STATUS_NETWORK_ACCESS_DENIED" "NT_STATUS_NOT_IMPLEMENTED" + "NT_STATUS_NO_LOGON_SERVERS" "NT_STATUS_NO_SUCH_FILE" "NT_STATUS_NO_SUCH_USER" "NT_STATUS_OBJECT_NAME_COLLISION" @@ -178,6 +190,26 @@ This list is used for tar-like copy of directories. See `tramp-actions-before-shell' for more info.") +(defconst tramp-smb-actions-get-acl + '((tramp-password-prompt-regexp tramp-action-password) + (tramp-wrong-passwd-regexp tramp-action-permission-denied) + (tramp-smb-errors tramp-action-permission-denied) + (tramp-process-alive-regexp tramp-smb-action-get-acl)) + "List of pattern/action pairs. +This list is used for smbcacls actions. + +See `tramp-actions-before-shell' for more info.") + +(defconst tramp-smb-actions-set-acl + '((tramp-password-prompt-regexp tramp-action-password) + (tramp-wrong-passwd-regexp tramp-action-permission-denied) + (tramp-smb-errors tramp-action-permission-denied) + (tramp-process-alive-regexp tramp-smb-action-set-acl)) + "List of pattern/action pairs. +This list is used for smbcacls actions. + +See `tramp-actions-before-shell' for more info.") + ;; New handlers should be added here. (defconst tramp-smb-file-name-handler-alist '(;; `access-file' performed by default handler. @@ -215,6 +247,7 @@ See `tramp-actions-before-shell' for more info.") (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) (file-notify-add-watch . tramp-handle-file-notify-add-watch) (file-notify-rm-watch . tramp-handle-file-notify-rm-watch) + (file-notify-valid-p . tramp-handle-file-notify-valid-p) (file-ownership-preserved-p . ignore) (file-readable-p . tramp-handle-file-exists-p) (file-regular-p . tramp-handle-file-regular-p) @@ -229,13 +262,13 @@ See `tramp-actions-before-shell' for more info.") (insert-directory . tramp-smb-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) (load . tramp-handle-load) - ;; `make-auto-save-file-name' performed by default handler. + (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-smb-handle-make-directory) (make-directory-internal . tramp-smb-handle-make-directory-internal) (make-symbolic-link . tramp-smb-handle-make-symbolic-link) (process-file . tramp-smb-handle-process-file) (rename-file . tramp-smb-handle-rename-file) - (set-file-acl . ignore) + (set-file-acl . tramp-smb-handle-set-file-acl) (set-file-modes . tramp-smb-handle-set-file-modes) (set-file-selinux-context . ignore) (set-file-times . ignore) @@ -251,6 +284,7 @@ See `tramp-actions-before-shell' for more info.") Operations not mentioned here will be handled by the default Emacs primitives.") ;; Options for remote processes via winexe. +;;;###tramp-autoload (defcustom tramp-smb-winexe-program "winexe" "Name of winexe client to run. If it isn't found in the local $PATH, the absolute path of winexe @@ -259,6 +293,7 @@ shall be given. This is needed for remote processes." :type 'string :version "24.3") +;;;###tramp-autoload (defcustom tramp-smb-winexe-shell-command "powershell.exe" "Shell to be used for processes on remote machines. This must be Powershell V2 compatible." @@ -266,6 +301,7 @@ This must be Powershell V2 compatible." :type 'string :version "24.3") +;;;###tramp-autoload (defcustom tramp-smb-winexe-shell-command-switch "-file -" "Command switch used together with `tramp-smb-winexe-shell-command'. This can be used to disable echo etc." @@ -358,140 +394,152 @@ pass to the OPERATION." (throw 'tramp-action 'ok))))) (defun tramp-smb-handle-copy-directory - (dirname newname &optional keep-date parents _copy-contents) + (dirname newname &optional keep-date parents copy-contents) "Like `copy-directory' for Tramp files." - (setq dirname (expand-file-name dirname) - newname (expand-file-name newname)) - (let ((t1 (tramp-tramp-file-p dirname)) - (t2 (tramp-tramp-file-p newname))) - (with-parsed-tramp-file-name (if t1 dirname newname) nil - (with-tramp-progress-reporter - v 0 (format "Copying %s to %s" dirname newname) - (cond - ;; We must use a local temporary directory. - ((and t1 t2) - (let ((tmpdir - (make-temp-name - (expand-file-name - tramp-temp-name-prefix - (tramp-compat-temporary-file-directory))))) - (unwind-protect - (progn - (tramp-compat-copy-directory dirname tmpdir keep-date parents) - (tramp-compat-copy-directory tmpdir newname keep-date parents)) - (tramp-compat-delete-directory tmpdir 'recursive)))) - - ;; We can copy recursively. - ((or t1 t2) - (when (and (file-directory-p newname) - (not (string-equal (file-name-nondirectory dirname) - (file-name-nondirectory newname)))) - (setq newname - (expand-file-name - (file-name-nondirectory dirname) newname)) - (if t2 (setq v (tramp-dissect-file-name newname)))) - (if (not (file-directory-p newname)) - (make-directory newname parents)) - - (setq tramp-current-method (tramp-file-name-method v) - tramp-current-user (tramp-file-name-user v) - tramp-current-host (tramp-file-name-real-host v)) - - (let* ((real-user (tramp-file-name-real-user v)) - (real-host (tramp-file-name-real-host v)) - (domain (tramp-file-name-domain v)) - (port (tramp-file-name-port v)) - (share (tramp-smb-get-share v)) - (localname (file-name-as-directory - (replace-regexp-in-string - "\\\\" "/" (tramp-smb-get-localname v)))) - (tmpdir (make-temp-name - (expand-file-name - tramp-temp-name-prefix - (tramp-compat-temporary-file-directory)))) - (args (list tramp-smb-program - (concat "//" real-host "/" share) "-E"))) - - (if (not (zerop (length real-user))) - (setq args (append args (list "-U" real-user))) - (setq args (append args (list "-N")))) - - (when domain (setq args (append args (list "-W" domain)))) - (when port (setq args (append args (list "-p" port)))) - (when tramp-smb-conf - (setq args (append args (list "-s" tramp-smb-conf)))) - (setq args - (if t1 - ;; Source is remote. - (append args - (list "-D" (shell-quote-argument localname) - "-c" (shell-quote-argument "tar qc - *") - "|" "tar" "xfC" "-" - (shell-quote-argument tmpdir))) - ;; Target is remote. - (append (list "tar" "cfC" "-" (shell-quote-argument dirname) - "." "|") - args - (list "-D" (shell-quote-argument localname) - "-c" (shell-quote-argument "tar qx -"))))) - - (unwind-protect - (with-temp-buffer - ;; Set the transfer process properties. - (tramp-set-connection-property - v "process-name" (buffer-name (current-buffer))) - (tramp-set-connection-property - v "process-buffer" (current-buffer)) - - (when t1 - ;; The smbclient tar command creates always complete - ;; paths. We must emulate the directory structure, - ;; and symlink to the real target. - (make-directory - (expand-file-name ".." (concat tmpdir localname)) 'parents) - (make-symbolic-link - newname (directory-file-name (concat tmpdir localname)))) - - ;; Use an asynchronous processes. By this, password - ;; can be handled. - (let* ((default-directory tmpdir) - (p (start-process-shell-command - (tramp-get-connection-name v) - (tramp-get-connection-buffer v) - (mapconcat 'identity args " ")))) - - (tramp-message - v 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-compat-set-process-query-on-exit-flag p nil) - (tramp-process-actions p v nil tramp-smb-actions-with-tar) - - (while (memq (process-status p) '(run open)) - (sit-for 0.1)) - (tramp-message v 6 "\n%s" (buffer-string)))) - - ;; Reset the transfer process properties. - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil) - (when t1 (delete-directory tmpdir 'recurse)))) - - ;; Handle KEEP-DATE argument. - (when keep-date - (set-file-times newname (nth 5 (file-attributes dirname)))) - - ;; Set the mode. - (unless keep-date - (set-file-modes newname (tramp-default-file-modes dirname))) - - ;; When newname did exist, we have wrong cached values. - (when t2 - (with-parsed-tramp-file-name newname nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname)))) - - ;; We must do it file-wise. - (t - (tramp-run-real-handler - 'copy-directory (list dirname newname keep-date parents)))))))) + (if copy-contents + ;; We must do it file-wise. + (tramp-run-real-handler + 'copy-directory (list dirname newname keep-date parents copy-contents)) + + (setq dirname (expand-file-name dirname) + newname (expand-file-name newname)) + (let ((t1 (tramp-tramp-file-p dirname)) + (t2 (tramp-tramp-file-p newname))) + (with-parsed-tramp-file-name (if t1 dirname newname) nil + (with-tramp-progress-reporter + v 0 (format "Copying %s to %s" dirname newname) + (cond + ;; We must use a local temporary directory. + ((and t1 t2) + (let ((tmpdir + (make-temp-name + (expand-file-name + tramp-temp-name-prefix + (tramp-compat-temporary-file-directory))))) + (unwind-protect + (progn + (make-directory tmpdir) + (tramp-compat-copy-directory + dirname tmpdir keep-date 'parents) + (tramp-compat-copy-directory + (expand-file-name (file-name-nondirectory dirname) tmpdir) + newname keep-date parents)) + (tramp-compat-delete-directory tmpdir 'recursive)))) + + ;; We can copy recursively. + ((or t1 t2) + (when (and (file-directory-p newname) + (not (string-equal (file-name-nondirectory dirname) + (file-name-nondirectory newname)))) + (setq newname + (expand-file-name + (file-name-nondirectory dirname) newname)) + (if t2 (setq v (tramp-dissect-file-name newname)))) + (if (not (file-directory-p newname)) + (make-directory newname parents)) + + (setq tramp-current-method (tramp-file-name-method v) + tramp-current-user (tramp-file-name-user v) + tramp-current-host (tramp-file-name-real-host v)) + + (let* ((real-user (tramp-file-name-real-user v)) + (real-host (tramp-file-name-real-host v)) + (domain (tramp-file-name-domain v)) + (port (tramp-file-name-port v)) + (share (tramp-smb-get-share v)) + (localname (file-name-as-directory + (tramp-compat-replace-regexp-in-string + "\\\\" "/" (tramp-smb-get-localname v)))) + (tmpdir (make-temp-name + (expand-file-name + tramp-temp-name-prefix + (tramp-compat-temporary-file-directory)))) + (args (list (concat "//" real-host "/" share) "-E"))) + + (if (not (zerop (length real-user))) + (setq args (append args (list "-U" real-user))) + (setq args (append args (list "-N")))) + + (when domain (setq args (append args (list "-W" domain)))) + (when port (setq args (append args (list "-p" port)))) + (when tramp-smb-conf + (setq args (append args (list "-s" tramp-smb-conf)))) + (setq args + (if t1 + ;; Source is remote. + (append args + (list "-D" (shell-quote-argument localname) + "-c" (shell-quote-argument "tar qc - *") + "|" "tar" "xfC" "-" + (shell-quote-argument tmpdir))) + ;; Target is remote. + (append (list "tar" "cfC" "-" + (shell-quote-argument dirname) "." "|") + args + (list "-D" (shell-quote-argument localname) + "-c" (shell-quote-argument "tar qx -"))))) + + (unwind-protect + (with-temp-buffer + ;; Set the transfer process properties. + (tramp-set-connection-property + v "process-name" (buffer-name (current-buffer))) + (tramp-set-connection-property + v "process-buffer" (current-buffer)) + + (when t1 + ;; The smbclient tar command creates always + ;; complete paths. We must emulate the + ;; directory structure, and symlink to the real + ;; target. + (make-directory + (expand-file-name + ".." (concat tmpdir localname)) 'parents) + (make-symbolic-link + newname (directory-file-name (concat tmpdir localname)))) + + ;; Use an asynchronous processes. By this, + ;; password can be handled. + (let* ((default-directory tmpdir) + (p (apply + 'start-process + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + tramp-smb-program args))) + + (tramp-message + v 6 "%s" (mapconcat 'identity (process-command p) " ")) + (tramp-set-connection-property p "vector" v) + (tramp-compat-set-process-query-on-exit-flag p nil) + (tramp-process-actions p v nil tramp-smb-actions-with-tar) + + (while (memq (process-status p) '(run open)) + (sit-for 0.1)) + (tramp-message v 6 "\n%s" (buffer-string)))) + + ;; Reset the transfer process properties. + (tramp-set-connection-property v "process-name" nil) + (tramp-set-connection-property v "process-buffer" nil) + (when t1 (tramp-compat-delete-directory tmpdir 'recurse)))) + + ;; Handle KEEP-DATE argument. + (when keep-date + (set-file-times newname (nth 5 (file-attributes dirname)))) + + ;; Set the mode. + (unless keep-date + (set-file-modes newname (tramp-default-file-modes dirname))) + + ;; When newname did exist, we have wrong cached values. + (when t2 + (with-parsed-tramp-file-name newname nil + (tramp-flush-file-property v (file-name-directory localname)) + (tramp-flush-file-property v localname)))) + + ;; We must do it file-wise. + (t + (tramp-run-real-handler + 'copy-directory (list dirname newname keep-date parents))))))))) (defun tramp-smb-handle-copy-file (filename newname &optional ok-if-already-exists keep-date @@ -502,7 +550,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setq filename (expand-file-name filename) newname (expand-file-name newname)) (with-tramp-progress-reporter - (tramp-dissect-file-name (if (file-remote-p filename) filename newname)) + (tramp-dissect-file-name + (if (tramp-tramp-file-p filename) filename newname)) 0 (format "Copying %s to %s" filename newname) (if (file-directory-p filename) @@ -537,7 +586,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (unless (tramp-smb-send-command v (format "put \"%s\" \"%s\"" filename (tramp-smb-get-localname v))) - (tramp-error v 'file-error "Cannot copy `%s'" filename)))))) + (tramp-error + v 'file-error "Cannot copy `%s' to `%s'" filename newname)))))) ;; KEEP-DATE handling. (when keep-date @@ -610,12 +660,12 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when full (setq result (mapcar - (lambda (x) (expand-file-name x directory)) + (lambda (x) (format "%s/%s" directory x)) result))) ;; Sort them if necessary. (unless nosort (setq result (sort result 'string-lessp))) - ;; That's it. - result)) + ;; Remove double entries. + (tramp-compat-delete-dups result))) (defun tramp-smb-handle-expand-file-name (name &optional dir) "Like `expand-file-name' for Tramp files." @@ -647,22 +697,83 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." method user host (tramp-run-real-handler 'expand-file-name (list localname)))))) +(defun tramp-smb-action-get-acl (proc vec) + "Read ACL data from connection buffer." + (when (not (memq (process-status proc) '(run open))) + ;; Accept pending output. + (while (tramp-accept-process-output proc 0.1)) + (with-current-buffer (tramp-get-connection-buffer vec) + ;; There might be a hidden password prompt. + (widen) + (tramp-message vec 10 "\n%s" (buffer-string)) + (goto-char (point-min)) + (while (and (not (eobp)) (not (looking-at "^REVISION:"))) + (forward-line) + (delete-region (point-min) (point))) + (while (and (not (eobp)) (looking-at "^.+:.+")) + (forward-line)) + (delete-region (point) (point-max)) + (throw 'tramp-action 'ok)))) + (defun tramp-smb-handle-file-acl (filename) "Like `file-acl' for Tramp files." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-acl" - (when (tramp-smb-send-command - v (format "getfacl \"%s\"" (tramp-smb-get-localname v))) - (with-current-buffer (tramp-get-connection-buffer v) - (goto-char (point-min)) - (while (looking-at "^#") - (forward-line) - (delete-region (point-min) (point))) - (goto-char (point-max)) - (delete-blank-lines) - (when (> (point-max) (point-min)) - (tramp-compat-funcall - 'substring-no-properties (buffer-string)))))))) + (when (executable-find tramp-smb-acl-program) + + (setq tramp-current-method (tramp-file-name-method v) + tramp-current-user (tramp-file-name-user v) + tramp-current-host (tramp-file-name-real-host v)) + + (let* ((real-user (tramp-file-name-real-user v)) + (real-host (tramp-file-name-real-host v)) + (domain (tramp-file-name-domain v)) + (port (tramp-file-name-port v)) + (share (tramp-smb-get-share v)) + (localname (tramp-compat-replace-regexp-in-string + "\\\\" "/" (tramp-smb-get-localname v))) + (args (list (concat "//" real-host "/" share) "-E"))) + + (if (not (zerop (length real-user))) + (setq args (append args (list "-U" real-user))) + (setq args (append args (list "-N")))) + + (when domain (setq args (append args (list "-W" domain)))) + (when port (setq args (append args (list "-p" port)))) + (when tramp-smb-conf + (setq args (append args (list "-s" tramp-smb-conf)))) + (setq + args + (append args (list (shell-quote-argument localname) "2>/dev/null"))) + + (unwind-protect + (with-temp-buffer + ;; Set the transfer process properties. + (tramp-set-connection-property + v "process-name" (buffer-name (current-buffer))) + (tramp-set-connection-property + v "process-buffer" (current-buffer)) + + ;; Use an asynchronous processes. By this, password + ;; can be handled. + (let ((p (apply + 'start-process + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + tramp-smb-acl-program args))) + + (tramp-message + v 6 "%s" (mapconcat 'identity (process-command p) " ")) + (tramp-set-connection-property p "vector" v) + (tramp-compat-set-process-query-on-exit-flag p nil) + (tramp-process-actions p v nil tramp-smb-actions-get-acl) + (when (> (point-max) (point-min)) + (tramp-compat-funcall + 'substring-no-properties (buffer-string))))) + + ;; Reset the transfer process properties. + (tramp-set-connection-property v "process-name" nil) + (tramp-set-connection-property v "process-buffer" nil))))))) (defun tramp-smb-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." @@ -671,7 +782,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname (format "file-attributes-%s" id-format) - (if (and (tramp-smb-get-share v) (tramp-smb-get-stat-capability v)) + (if (tramp-smb-get-stat-capability v) (tramp-smb-do-file-attributes-with-stat v id-format) ;; Reading just the filename entry via "dir localname" is not ;; possible, because when filename is a directory, some @@ -822,101 +933,109 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (filename switches &optional wildcard full-directory-p) "Like `insert-directory' for Tramp files." (setq filename (expand-file-name filename)) + (unless switches (setq switches "")) + ;; Mark trailing "/". + (when (and (zerop (length (file-name-nondirectory filename))) + (not full-directory-p)) + (setq switches (concat switches "F"))) (if full-directory-p ;; Called from `dired-add-entry'. (setq filename (file-name-as-directory filename)) (setq filename (directory-file-name filename))) (with-parsed-tramp-file-name filename nil - (save-match-data - (let ((base (file-name-nondirectory filename)) - ;; We should not destroy the cache entry. - (entries (copy-sequence - (tramp-smb-get-file-entries - (file-name-directory filename))))) - - (when wildcard - (string-match "\\." base) - (setq base (replace-match "\\\\." nil nil base)) - (string-match "\\*" base) - (setq base (replace-match ".*" nil nil base)) - (string-match "\\?" base) - (setq base (replace-match ".?" nil nil base))) - - ;; Filter entries. - (setq entries - (delq - nil - (if (or wildcard (zerop (length base))) - ;; Check for matching entries. - (mapcar - (lambda (x) - (when (string-match - (format "^%s" base) (nth 0 x)) - x)) - entries) - ;; We just need the only and only entry FILENAME. - (list (assoc base entries))))) - - ;; Sort entries. - (setq entries - (sort - entries - (lambda (x y) - (if (string-match "t" switches) - ;; Sort by date. - (tramp-time-less-p (nth 3 y) (nth 3 x)) - ;; Sort by name. - (string-lessp (nth 0 x) (nth 0 y)))))) - - ;; Handle "-F" switch. - (when (string-match "F" switches) + (with-tramp-progress-reporter v 0 (format "Opening directory %s" filename) + (save-match-data + (let ((base (file-name-nondirectory filename)) + ;; We should not destroy the cache entry. + (entries (copy-sequence + (tramp-smb-get-file-entries + (file-name-directory filename))))) + + (when wildcard + (string-match "\\." base) + (setq base (replace-match "\\\\." nil nil base)) + (string-match "\\*" base) + (setq base (replace-match ".*" nil nil base)) + (string-match "\\?" base) + (setq base (replace-match ".?" nil nil base))) + + ;; Filter entries. + (setq entries + (delq + nil + (if (or wildcard (zerop (length base))) + ;; Check for matching entries. + (mapcar + (lambda (x) + (when (string-match + (format "^%s" base) (nth 0 x)) + x)) + entries) + ;; We just need the only and only entry FILENAME. + (list (assoc base entries))))) + + ;; Sort entries. + (setq entries + (sort + entries + (lambda (x y) + (if (string-match "t" switches) + ;; Sort by date. + (time-less-p (nth 3 y) (nth 3 x)) + ;; Sort by name. + (string-lessp (nth 0 x) (nth 0 y)))))) + + ;; Handle "-F" switch. + (when (string-match "F" switches) + (mapc + (lambda (x) + (when (not (zerop (length (car x)))) + (cond + ((char-equal ?d (string-to-char (nth 1 x))) + (setcar x (concat (car x) "/"))) + ((char-equal ?x (string-to-char (nth 1 x))) + (setcar x (concat (car x) "*")))))) + entries)) + + ;; Print entries. (mapc (lambda (x) - (when (not (zerop (length (car x)))) - (cond - ((char-equal ?d (string-to-char (nth 1 x))) - (setcar x (concat (car x) "/"))) - ((char-equal ?x (string-to-char (nth 1 x))) - (setcar x (concat (car x) "*")))))) - entries)) - - ;; Print entries. - (mapc - (lambda (x) - (when (not (zerop (length (nth 0 x)))) - (let ((attr - (when (tramp-smb-get-stat-capability v) - (ignore-errors - (file-attributes filename 'string))))) - (insert - (format - "%10s %3d %-8s %-8s %8s %s " - (or (nth 8 attr) (nth 1 x)) ; mode - (or (nth 1 attr) 1) ; inode - (or (nth 2 attr) "nobody") ; uid - (or (nth 3 attr) "nogroup") ; gid - (or (nth 7 attr) (nth 2 x)) ; size - (format-time-string - (if (tramp-time-less-p - (tramp-time-subtract (current-time) (nth 3 x)) - tramp-half-a-year) - "%b %e %R" - "%b %e %Y") - (nth 3 x)))) ; date + (when (not (zerop (length (nth 0 x)))) + (when (string-match "l" switches) + (let ((attr + (when (tramp-smb-get-stat-capability v) + (ignore-errors + (file-attributes filename 'string))))) + (insert + (format + "%10s %3d %-8s %-8s %8s %s " + (or (nth 8 attr) (nth 1 x)) ; mode + (or (nth 1 attr) 1) ; inode + (or (nth 2 attr) "nobody") ; uid + (or (nth 3 attr) "nogroup") ; gid + (or (nth 7 attr) (nth 2 x)) ; size + (format-time-string + (if (time-less-p (time-subtract (current-time) (nth 3 x)) + tramp-half-a-year) + "%b %e %R" + "%b %e %Y") + (nth 3 x)))))) ; date + ;; We mark the file name. The inserted name could be - ;; from somewhere else, so we use the relative file - ;; name of `default-directory'. + ;; from somewhere else, so we use the relative file name + ;; of `default-directory'. (let ((start (point))) (insert (format "%s\n" (file-relative-name (expand-file-name - (nth 0 x) (file-name-directory filename))))) + (nth 0 x) (file-name-directory filename)) + (when full-directory-p (file-name-directory filename))))) (put-text-property start (1- (point)) 'dired-filename t)) (forward-line) - (beginning-of-line)))) - entries))))) + (beginning-of-line))) + entries)))))) (defun tramp-smb-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." @@ -1110,8 +1229,8 @@ target of the symlink differ." (error (setq ret 1))) - ;; We should show the output anyway. - (when (and outbuf display) (display-buffer outbuf)) + ;; We should redisplay the output. + (when (and display outbuf (get-buffer-window outbuf t)) (redisplay)) ;; Cleanup. We remove all file cache values for the connection, ;; because the remote process could have changed them. @@ -1122,9 +1241,9 @@ target of the symlink differ." (kill-buffer (tramp-get-connection-property v "process-buffer" nil))) ;; `process-file-side-effects' has been introduced with GNU - ;; Emacs 23.2. If set to `nil', no remote file will be changed + ;; Emacs 23.2. If set to nil, no remote file will be changed ;; by `program'. If it doesn't exist, we assume its default - ;; value `t'. + ;; value t. (unless (and (boundp 'process-file-side-effects) (not (symbol-value 'process-file-side-effects))) (tramp-flush-directory-property v "")) @@ -1144,14 +1263,16 @@ target of the symlink differ." (file-exists-p newname)) (tramp-error (tramp-dissect-file-name - (if (file-remote-p filename) filename newname)) + (if (tramp-tramp-file-p filename) filename newname)) 'file-already-exists newname)) (with-tramp-progress-reporter - (tramp-dissect-file-name (if (file-remote-p filename) filename newname)) + (tramp-dissect-file-name + (if (tramp-tramp-file-p filename) filename newname)) 0 (format "Renaming %s to %s" filename newname) - (if (and (tramp-equal-remote filename newname) + (if (and (not (file-exists-p newname)) + (tramp-equal-remote filename newname) (string-equal (tramp-smb-get-share (tramp-dissect-file-name filename)) (tramp-smb-get-share (tramp-dissect-file-name newname)))) @@ -1161,6 +1282,8 @@ target of the symlink differ." ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. + (tramp-flush-file-property v1 (file-name-directory v1-localname)) + (tramp-flush-file-property v1 v1-localname) (tramp-flush-file-property v2 (file-name-directory v2-localname)) (tramp-flush-file-property v2 v2-localname) (unless (tramp-smb-get-share v2) @@ -1178,6 +1301,86 @@ target of the symlink differ." (tramp-compat-delete-directory filename 'recursive) (delete-file filename))))) +(defun tramp-smb-action-set-acl (proc vec) + "Read ACL data from connection buffer." + (when (not (memq (process-status proc) '(run open))) + ;; Accept pending output. + (while (tramp-accept-process-output proc 0.1)) + (with-current-buffer (tramp-get-connection-buffer vec) + (tramp-message vec 10 "\n%s" (buffer-string)) + (throw 'tramp-action 'ok)))) + +(defun tramp-smb-handle-set-file-acl (filename acl-string) + "Like `set-file-acl' for Tramp files." + (ignore-errors + (with-parsed-tramp-file-name filename nil + (when (and (stringp acl-string) (executable-find tramp-smb-acl-program)) + (setq tramp-current-method (tramp-file-name-method v) + tramp-current-user (tramp-file-name-user v) + tramp-current-host (tramp-file-name-real-host v)) + (tramp-set-file-property v localname "file-acl" 'undef) + + (let* ((real-user (tramp-file-name-real-user v)) + (real-host (tramp-file-name-real-host v)) + (domain (tramp-file-name-domain v)) + (port (tramp-file-name-port v)) + (share (tramp-smb-get-share v)) + (localname (tramp-compat-replace-regexp-in-string + "\\\\" "/" (tramp-smb-get-localname v))) + (args (list (concat "//" real-host "/" share) "-E" "-S" + (tramp-compat-replace-regexp-in-string + "\n" "," acl-string)))) + + (if (not (zerop (length real-user))) + (setq args (append args (list "-U" real-user))) + (setq args (append args (list "-N")))) + + (when domain (setq args (append args (list "-W" domain)))) + (when port (setq args (append args (list "-p" port)))) + (when tramp-smb-conf + (setq args (append args (list "-s" tramp-smb-conf)))) + (setq + args + (append args (list (shell-quote-argument localname) + "&&" "echo" "tramp_exit_status" "0" + "||" "echo" "tramp_exit_status" "1"))) + + (unwind-protect + (with-temp-buffer + ;; Set the transfer process properties. + (tramp-set-connection-property + v "process-name" (buffer-name (current-buffer))) + (tramp-set-connection-property + v "process-buffer" (current-buffer)) + + ;; Use an asynchronous processes. By this, password can + ;; be handled. + (let ((p (apply + 'start-process + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + tramp-smb-acl-program args))) + + (tramp-message + v 6 "%s" (mapconcat 'identity (process-command p) " ")) + (tramp-set-connection-property p "vector" v) + (tramp-compat-set-process-query-on-exit-flag p nil) + (tramp-process-actions p v nil tramp-smb-actions-set-acl) + (goto-char (point-max)) + (unless (re-search-backward "tramp_exit_status [0-9]+" nil t) + (tramp-error + v 'file-error + "Couldn't find exit status of `%s'" tramp-smb-acl-program)) + (skip-chars-forward "^ ") + (when (zerop (read (current-buffer))) + ;; Success. + (tramp-set-file-property v localname "file-acl" acl-string) + t))) + + ;; Reset the transfer process properties. + (tramp-set-connection-property v "process-name" nil) + (tramp-set-connection-property v "process-buffer" nil))))))) + (defun tramp-smb-handle-set-file-modes (filename mode) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil @@ -1257,9 +1460,6 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." "Like `write-region' for Tramp files." (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil - (unless (eq append nil) - (tramp-error - v 'file-error "Cannot append to file using Tramp (`%s')" filename)) ;; XEmacs takes a coding system as the seventh argument, not `confirm'. (when (and (not (featurep 'xemacs)) confirm (file-exists-p filename)) @@ -1272,6 +1472,8 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (tramp-flush-file-property v localname) (let ((curbuf (current-buffer)) (tmpfile (tramp-compat-make-temp-file filename))) + (when (and append (file-exists-p filename)) + (copy-file filename tmpfile 'ok)) ;; We say `no-message' here because we don't want the visited file ;; modtime data to be clobbered from the temp file. We call ;; `set-visited-file-modtime' ourselves later on. @@ -1364,14 +1566,14 @@ Result is a list of (LOCALNAME MODE SIZE MONTH DAY TIME YEAR)." (while (not (eobp)) (setq entry (tramp-smb-read-file-entry share)) (forward-line) - (when entry (add-to-list 'res entry)))) + (when entry (push entry res)))) ;; Cache share entries. (unless share (tramp-set-connection-property v "share-cache" res))) ;; Add directory itself. - (add-to-list 'res '("" "drwxrwxrwx" 0 (0 0))) + (push '("" "drwxrwxrwx" 0 (0 0)) res) ;; There's a very strange error (debugged with XEmacs 21.4.14) ;; If there's no short delay, it returns nil. No idea about. @@ -1541,11 +1743,12 @@ Result is the list (LOCALNAME MODE SIZE MTIME)." (defun tramp-smb-get-stat-capability (vec) "Check, whether the SMB server supports the STAT command." ;; When we are not logged in yet, we return nil. - (if (let ((p (tramp-get-connection-process vec))) - (and p (processp p) (memq (process-status p) '(run open)))) + (if (and (tramp-smb-get-share vec) + (let ((p (tramp-get-connection-process vec))) + (and p (processp p) (memq (process-status p) '(run open))))) (with-tramp-connection-property (tramp-get-connection-process vec) "stat-capability" - (tramp-smb-send-command vec "stat .")))) + (tramp-smb-send-command vec "stat \"/\"")))) ;; Connection functions. @@ -1564,6 +1767,8 @@ Does not do anything if a connection is already open, but re-opens the connection if a previous connection has died for some reason. If ARGUMENT is non-nil, use it as argument for `tramp-smb-winexe-program', and suppress any checks." + (tramp-check-proper-method-and-host vec) + (let* ((share (tramp-smb-get-share vec)) (buf (tramp-get-connection-buffer vec)) (p (get-buffer-process buf))) @@ -1672,6 +1877,7 @@ If ARGUMENT is non-nil, use it as argument for (tramp-message vec 6 "%s" (mapconcat 'identity (process-command p) " ")) + (tramp-set-connection-property p "vector" vec) (tramp-compat-set-process-query-on-exit-flag p nil) ;; Set variables for computing the prompt for reading password. @@ -1717,11 +1923,15 @@ If ARGUMENT is non-nil, use it as argument for (error (with-current-buffer (tramp-get-connection-buffer vec) (goto-char (point-min)) - (if (search-forward-regexp - tramp-smb-wrong-passwd-regexp nil t) + (if (and (boundp 'auth-sources) + (symbol-value 'auth-sources) + (search-forward-regexp + tramp-smb-wrong-passwd-regexp nil t)) ;; Disable `auth-source' and `password-cache'. (let (auth-sources) - (tramp-cleanup vec) + (tramp-message + vec 3 "Retry connection with new password") + (tramp-cleanup-connection vec t) (tramp-smb-maybe-open-connection vec argument)) ;; Propagate the error. (signal (car err) (cdr err))))))))))))) @@ -1785,10 +1995,6 @@ Returns nil if an error message has appeared." (defun tramp-smb-call-winexe (vec) "Apply a remote command, if possible, using `tramp-smb-winexe-program'." - ;; We call `tramp-get-buffer' in order to get a debug buffer for - ;; messages. - (tramp-get-buffer vec) - ;; Check for program. (unless (executable-find tramp-smb-winexe-program) (tramp-error diff --git a/lisp/net/tramp-uu.el b/lisp/net/tramp-uu.el index 6cf5baeccd8..efa43b5880e 100644 --- a/lisp/net/tramp-uu.el +++ b/lisp/net/tramp-uu.el @@ -1,6 +1,6 @@ ;;; tramp-uu.el --- uuencode in Lisp -;; Copyright (C) 2002-2013 Free Software Foundation, Inc. +;; Copyright (C) 2002-2015 Free Software Foundation, Inc. ;; Author: Kai Großjohann <kai.grossjohann@gmx.net> ;; Keywords: comm, terminals diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index cd7d17b130c..2f811bb73ca 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1,6 +1,6 @@ ;;; tramp.el --- Transparent Remote Access, Multiple Protocol -;; Copyright (C) 1998-2013 Free Software Foundation, Inc. +;; Copyright (C) 1998-2015 Free Software Foundation, Inc. ;; Author: Kai Großjohann <kai.grossjohann@gmx.net> ;; Michael Albinus <michael.albinus@gmx.de> @@ -49,9 +49,8 @@ ;; http://lists.gnu.org/mailman/listinfo/tramp-devel ;; ;; For the adventurous, the current development sources are available -;; via CVS. You can find instructions about this at the following URL: +;; via Git. You can find instructions about this at the following URL: ;; http://savannah.gnu.org/projects/tramp/ -;; Click on "CVS" in the navigation bar near the top. ;; ;; Don't forget to put on your asbestos longjohns, first! @@ -65,7 +64,7 @@ (defvar bkup-backup-directory-info) (defvar directory-sep-char) (defvar eshell-path-env) -(defvar file-notify-descriptors) +(defvar ls-lisp-use-insert-directory-program) (defvar outline-regexp) ;;; User Customizable Internal Variables: @@ -74,6 +73,7 @@ "Edit remote files with a combination of ssh, scp, etc." :group 'files :group 'comm + :link '(custom-manual "(tramp)Top") :version "22.1") ;; Maybe we need once a real Tramp mode, with key bindings etc. @@ -110,9 +110,9 @@ Any level x includes messages for all levels 1 .. x-1. The levels are Each element looks like (REGEXP . DIRECTORY), with the same meaning like in `backup-directory-alist'. If a Tramp file is backed up, and DIRECTORY is a local file name, the backup directory is prepended with Tramp file -name prefix \(method, user, host\) of file. +name prefix \(method, user, host) of file. -\(setq tramp-backup-directory-alist backup-directory-alist\) +\(setq tramp-backup-directory-alist backup-directory-alist) gives the same backup policy for Tramp files on their hosts like the policy for local files." @@ -129,9 +129,9 @@ policy for local files." It has the same meaning like `bkup-backup-directory-info' from package `backup-dir'. If a Tramp file is backed up, and BACKUP-DIR is a local file name, the backup directory is prepended with Tramp file name prefix -\(method, user, host\) of file. +\(method, user, host) of file. -\(setq tramp-bkup-backup-directory-info bkup-backup-directory-info\) +\(setq tramp-bkup-backup-directory-info bkup-backup-directory-info) gives the same backup policy for Tramp files on their hosts like the policy for local files." @@ -147,9 +147,11 @@ policy for local files." (defcustom tramp-auto-save-directory nil "Put auto-save files in this directory, if set. -The idea is to use a local directory so that auto-saving is faster." +The idea is to use a local directory so that auto-saving is faster. +This setting has precedence over `auto-save-file-name-transforms'." :group 'tramp - :type '(choice (const nil) string)) + :type '(choice (const :tag "Use default" nil) + (directory :tag "Auto save directory name"))) (defcustom tramp-encoding-shell (if (memq system-type '(windows-nt)) @@ -208,6 +210,12 @@ pair of the form (KEY VALUE). The following KEYs are defined: for it. Also note that \"/bin/sh\" exists on all Unixen, this might not be true for the value that you decide to use. You Have Been Warned. + * `tramp-remote-shell-login' + This specifies the arguments to let `tramp-remote-shell' run + as a login shell. It defaults to (\"-l\"), but some shells, + like ksh, require another argument. See + `tramp-connection-properties' for a way to overwrite the + default value. * `tramp-remote-shell-args' For implementation of `shell-command', this specifies the arguments to let `tramp-remote-shell' run a single command. @@ -230,6 +238,9 @@ pair of the form (KEY VALUE). The following KEYs are defined: `tramp-make-tramp-temp-file'. \"%k\" indicates the keep-date parameter of a program, if exists. \"%c\" adds additional `tramp-ssh-controlmaster-options' options for the first hop. + * `tramp-login-env' + A list of environment variables and their values, which will + be set when calling `tramp-login-program'. * `tramp-async-args' When an asynchronous process is started, we know already that the connection works. Therefore, we can pass additional @@ -237,11 +248,21 @@ pair of the form (KEY VALUE). The following KEYs are defined: tamper the process output. * `tramp-copy-program' This specifies the name of the program to use for remotely copying - the file; this might be the absolute filename of rcp or the name of - a workalike program. + the file; this might be the absolute filename of scp or the name of + a workalike program. It is always applied on the local host. * `tramp-copy-args' This specifies the list of parameters to pass to the above mentioned program, the hints for `tramp-login-args' also apply here. + * `tramp-copy-env' + A list of environment variables and their values, which will + be set when calling `tramp-copy-program'. + * `tramp-remote-copy-program' + The listener program to be applied on remote side, if needed. + * `tramp-remote-copy-args' + The list of parameters to pass to the listener program, the hints + for `tramp-login-args' also apply here. Additionally, \"%r\" could + be used here and in `tramp-copy-args'. It denotes a randomly + chosen port for the remote listener. * `tramp-copy-keep-date' This specifies whether the copying program when the preserves the timestamp of the original file. @@ -269,7 +290,7 @@ pair of the form (KEY VALUE). The following KEYs are defined: What does all this mean? Well, you should specify `tramp-login-program' for all methods; this program is used to log in to the remote site. Then, there are two ways to actually transfer the files between the local and the -remote side. One way is using an additional rcp-like program. If you want +remote side. One way is using an additional scp-like program. If you want to do this, set `tramp-copy-program' in the method. Another possibility for file transfer is inline transfer, i.e. the @@ -287,40 +308,13 @@ are fit for gateways must have `tramp-default-port' at least. Notes: -When using `su' or `sudo' the phrase `open connection to a remote -host' sounds strange, but it is used nevertheless, for consistency. +When using `su' or `sudo' the phrase \"open connection to a remote +host\" sounds strange, but it is used nevertheless, for consistency. No connection is opened to a remote host, but `su' or `sudo' is started on the local host. You should specify a remote host `localhost' or the name of the local host. Another host name is useful only in combination with `tramp-default-proxies-alist'.") -;;;###tramp-autoload -(defconst tramp-ssh-controlmaster-options - (let ((result "")) - (ignore-errors - (with-temp-buffer - (call-process "ssh" nil t nil "-o" "ControlMaster") - (goto-char (point-min)) - (when (search-forward-regexp "Missing ControlMaster argument" nil t) - (setq result "-o ControlPath=%t.%%r@%%h:%%p -o ControlMaster=auto"))) - (when result - (with-temp-buffer - (call-process "ssh" nil t nil "-o" "ControlPersist") - (goto-char (point-min)) - (when (search-forward-regexp "Missing ControlPersist argument" nil t) - (setq result (concat result " -o ControlPersist=no")))))) - result) - "Call ssh to detect whether it supports the Control* arguments. -Return a string to be used in `tramp-methods'.") - -;;;###tramp-autoload -(defcustom tramp-use-ssh-controlmaster-options - (not (zerop (length tramp-ssh-controlmaster-options))) - "Whether to use `tramp-ssh-controlmaster-options'." - :group 'tramp - :version "24.4" - :type 'boolean) - (defcustom tramp-default-method ;; An external copy method seems to be preferred, because it performs ;; much better for large files, and it hasn't too serious delays @@ -351,9 +345,7 @@ Return a string to be used in `tramp-methods'.") (fboundp 'auth-source-search) ;; ssh-agent is running. (getenv "SSH_AUTH_SOCK") - (getenv "SSH_AGENT_PID") - ;; We could reuse the connection. - (> (length tramp-ssh-controlmaster-options) 0)) + (getenv "SSH_AGENT_PID")) "scp" "ssh")) ;; Fallback. @@ -472,15 +464,15 @@ host runs a registered shell, it shall be added to this list, too." (concat "\\`" (regexp-opt - (list "localhost" "localhost6" (system-name) "127\.0\.0\.1" "::1") t) + (list "localhost" "localhost6" (system-name) "127.0.0.1" "::1") t) "\\'") "Host names which are regarded as local host.") (defvar tramp-completion-function-alist nil "Alist of methods for remote files. -This is a list of entries of the form \(NAME PAIR1 PAIR2 ...\). +This is a list of entries of the form \(NAME PAIR1 PAIR2 ...). Each NAME stands for a remote access method. Each PAIR is of the form -\(FUNCTION FILE\). FUNCTION is responsible to extract user names and host +\(FUNCTION FILE). FUNCTION is responsible to extract user names and host names from FILE for completion. The following predefined FUNCTIONs exists: * `tramp-parse-rhosts' for \"~/.rhosts\" like files, @@ -493,7 +485,7 @@ names from FILE for completion. The following predefined FUNCTIONs exists: * `tramp-parse-netrc' for \"~/.netrc\" like files. * `tramp-parse-putty' for PuTTY registered sessions. -FUNCTION can also be a customer defined function. For more details see +FUNCTION can also be a user defined function. For more details see the info pages.") (defconst tramp-echo-mark-marker "_echo" @@ -535,7 +527,7 @@ if you need to change this." :type 'string) (defcustom tramp-login-prompt-regexp - ".*ogin\\( .*\\)?: *" + ".*\\(user\\|login\\)\\( .*\\)?: *" "Regexp matching login-like prompts. The regexp should match at end of buffer. @@ -566,11 +558,15 @@ This regexp must match both `tramp-initial-end-of-output' and :type 'regexp) (defcustom tramp-password-prompt-regexp - "^.*\\([pP]assword\\|[pP]assphrase\\).*:\^@? *" + (format "^.*\\(%s\\).*:\^@? *" + (if (boundp 'password-word-equivalents) + (regexp-opt (symbol-value 'password-word-equivalents)) + "password\\|passphrase")) "Regexp matching password-like prompts. The regexp should match at end of buffer. The `sudo' program appears to insert a `^@' character into the prompt." + :version "24.4" :group 'tramp :type 'regexp) @@ -690,7 +686,7 @@ Useful for \"rsync\" like methods.") ;; Tramp only knows how to deal with `file-name-handler-alist', not ;; the other places. -;; Currently, we have the choice between 'ftp, 'sep, and 'url. +;; Currently, we have the choice between 'ftp and 'sep. ;;;###autoload (defcustom tramp-syntax (if (featurep 'xemacs) 'sep 'ftp) @@ -699,20 +695,15 @@ Useful for \"rsync\" like methods.") It can have the following values: 'ftp -- Ange-FTP respective EFS like syntax (GNU Emacs default) - 'sep -- Syntax as defined for XEmacs (not available yet for GNU Emacs) - 'url -- URL-like syntax." + 'sep -- Syntax as defined for XEmacs." :group 'tramp - :type (if (featurep 'xemacs) - '(choice (const :tag "EFS" ftp) - (const :tag "XEmacs" sep) - (const :tag "URL" url)) - '(choice (const :tag "Ange-FTP" ftp) - (const :tag "URL" url)))) + :version "24.4" + :type `(choice (const :tag ,(if (featurep 'xemacs) "EFS" "Ange-FTP") ftp) + (const :tag "XEmacs" sep))) (defconst tramp-prefix-format (cond ((equal tramp-syntax 'ftp) "/") ((equal tramp-syntax 'sep) "/[") - ((equal tramp-syntax 'url) "/") (t (error "Wrong `tramp-syntax' defined"))) "String matching the very beginning of Tramp file names. Used in `tramp-make-tramp-file-name'.") @@ -729,7 +720,6 @@ Should always start with \"^\". Derived from `tramp-prefix-format'.") (defconst tramp-postfix-method-format (cond ((equal tramp-syntax 'ftp) ":") ((equal tramp-syntax 'sep) "/") - ((equal tramp-syntax 'url) "://") (t (error "Wrong `tramp-syntax' defined"))) "String matching delimiter between method and user or host names. Used in `tramp-make-tramp-file-name'.") @@ -776,7 +766,6 @@ Derived from `tramp-postfix-user-format'.") (defconst tramp-prefix-ipv6-format (cond ((equal tramp-syntax 'ftp) "[") ((equal tramp-syntax 'sep) "") - ((equal tramp-syntax 'url) "[") (t (error "Wrong `tramp-syntax' defined"))) "String matching left hand side of IPv6 addresses. Used in `tramp-make-tramp-file-name'.") @@ -796,7 +785,6 @@ Derived from `tramp-prefix-ipv6-format'.") (defconst tramp-postfix-ipv6-format (cond ((equal tramp-syntax 'ftp) "]") ((equal tramp-syntax 'sep) "") - ((equal tramp-syntax 'url) "]") (t (error "Wrong `tramp-syntax' defined"))) "String matching right hand side of IPv6 addresses. Used in `tramp-make-tramp-file-name'.") @@ -809,7 +797,6 @@ Derived from `tramp-postfix-ipv6-format'.") (defconst tramp-prefix-port-format (cond ((equal tramp-syntax 'ftp) "#") ((equal tramp-syntax 'sep) "#") - ((equal tramp-syntax 'url) ":") (t (error "Wrong `tramp-syntax' defined"))) "String matching delimiter between host names and port numbers.") @@ -838,7 +825,6 @@ Derived from `tramp-postfix-hop-format'.") (defconst tramp-postfix-host-format (cond ((equal tramp-syntax 'ftp) ":") ((equal tramp-syntax 'sep) "]") - ((equal tramp-syntax 'url) "") (t (error "Wrong `tramp-syntax' defined"))) "String matching delimiter between host names and localnames. Used in `tramp-make-tramp-file-name'.") @@ -858,7 +844,7 @@ Derived from `tramp-postfix-host-format'.") "\\(?:" "\\(" tramp-method-regexp "\\)" tramp-postfix-method-regexp "\\)?" "\\(?:" "\\(" tramp-user-regexp "\\)" tramp-postfix-user-regexp "\\)?" "\\(" "\\(?:" tramp-host-regexp "\\|" - tramp-prefix-ipv6-regexp tramp-ipv6-regexp + tramp-prefix-ipv6-regexp "\\(?:" tramp-ipv6-regexp "\\)?" tramp-postfix-ipv6-regexp "\\)" "\\(?:" tramp-prefix-port-regexp tramp-port-regexp "\\)?" "\\)?") "Regular expression matching a Tramp file name between prefix and postfix.") @@ -894,8 +880,8 @@ See also `tramp-file-name-regexp'.") ;;;###autoload (defconst tramp-file-name-regexp-unified (if (memq system-type '(cygwin windows-nt)) - "\\`/\\([^[/|:]\\{2,\\}\\|[^/|]\\{2,\\}]\\):" - "\\`/\\([^[/|:]+\\|[^/|]+]\\):") + "\\`/\\(\\[.*\\]\\|[^/|:]\\{2,\\}[^/|]*\\):" + "\\`/[^/|:][^/|]*:") "Value for `tramp-file-name-regexp' for unified remoting. Emacs (not XEmacs) uses a unified filename syntax for Ange-FTP and Tramp. See `tramp-file-name-structure' for more explanations. @@ -909,15 +895,9 @@ XEmacs uses a separate filename syntax for Tramp and EFS. See `tramp-file-name-structure' for more explanations.") ;;;###autoload -(defconst tramp-file-name-regexp-url "\\`/[^/|:]+://" - "Value for `tramp-file-name-regexp' for URL-like remoting. -See `tramp-file-name-structure' for more explanations.") - -;;;###autoload (defconst tramp-file-name-regexp (cond ((equal tramp-syntax 'ftp) tramp-file-name-regexp-unified) ((equal tramp-syntax 'sep) tramp-file-name-regexp-separate) - ((equal tramp-syntax 'url) tramp-file-name-regexp-url) (t (error "Wrong `tramp-syntax' defined"))) "Regular expression matching file names handled by Tramp. This regexp should match Tramp file names but no other file names. @@ -928,7 +908,7 @@ and is a bit too general, then some files might be considered Tramp files which are not really Tramp files. Please note that the entry in `file-name-handler-alist' is made when -this file \(tramp.el\) is loaded. This means that this variable must be set +this file \(tramp.el) is loaded. This means that this variable must be set before loading tramp.el. Alternatively, `file-name-handler-alist' can be updated after changing this variable. @@ -952,22 +932,15 @@ XEmacs uses a separate filename syntax for Tramp and EFS. See `tramp-file-name-structure' for more explanations.") ;;;###autoload -(defconst tramp-completion-file-name-regexp-url - "\\`/[^/:]+\\(:\\(/\\(/[^/]*\\)?\\)?\\)?\\'" - "Value for `tramp-completion-file-name-regexp' for URL-like remoting. -See `tramp-file-name-structure' for more explanations.") - -;;;###autoload (defconst tramp-completion-file-name-regexp (cond ((equal tramp-syntax 'ftp) tramp-completion-file-name-regexp-unified) ((equal tramp-syntax 'sep) tramp-completion-file-name-regexp-separate) - ((equal tramp-syntax 'url) tramp-completion-file-name-regexp-url) (t (error "Wrong `tramp-syntax' defined"))) "Regular expression matching file names handled by Tramp completion. This regexp should match partial Tramp file names only. Please note that the entry in `file-name-handler-alist' is made when -this file \(tramp.el\) is loaded. This means that this variable must be set +this file \(tramp.el) is loaded. This means that this variable must be set before loading tramp.el. Alternatively, `file-name-handler-alist' can be updated after changing this variable. @@ -999,14 +972,14 @@ checked via the following code: (erase-buffer) (let ((proc (start-process (buffer-name) (current-buffer) \"ssh\" \"-l\" user host \"wc\" \"-c\"))) - (when (memq (process-status proc) '(run open)) + (when (memq (process-status proc) \\='(run open)) (process-send-string proc (make-string sent ?\\ )) (process-send-eof proc) (process-send-eof proc)) (while (not (progn (goto-char (point-min)) (re-search-forward \"\\\\w+\" (point-max) t))) (accept-process-output proc 1)) - (when (memq (process-status proc) '(run open)) + (when (memq (process-status proc) \\='(run open)) (setq received (string-to-number (match-string 0))) (delete-process proc) (message \"Bytes sent: %s\\tBytes received: %s\" sent received) @@ -1020,18 +993,18 @@ checked via the following code: In the Emacs normally running Tramp, evaluate the above code \(replace \"xxx\" and \"yyy\" by the remote user and host name, -respectively\). You can do this, for example, by pasting it into +respectively). You can do this, for example, by pasting it into the `*scratch*' buffer and then hitting C-j with the cursor after the last closing parenthesis. Note that it works only if you have configured -\"ssh\" to run without password query, see ssh-agent\(1\). +\"ssh\" to run without password query, see ssh-agent(1). You will see the number of bytes sent successfully to the remote host. If that number exceeds 1000, you can stop the execution by hitting C-g, because your Emacs is likely clean. When it is necessary to set `tramp-chunksize', you might consider to -use an out-of-the-band method \(like \"scp\"\) instead of an internal one -\(like \"ssh\"\), because setting `tramp-chunksize' to non-nil decreases +use an out-of-the-band method \(like \"scp\") instead of an internal one +\(like \"ssh\"), because setting `tramp-chunksize' to non-nil decreases performance. If your Emacs is buggy, the code stops and gives you an indication @@ -1057,7 +1030,9 @@ opening a connection to a remote host." (defcustom tramp-connection-timeout 60 "Defines the max time to wait for establishing a connection (in seconds). -This can be overwritten for different connection types in `tramp-methods'." +This can be overwritten for different connection types in `tramp-methods'. + +The timeout does not include the time reading a password." :group 'tramp :version "24.4" :type 'integer) @@ -1067,7 +1042,7 @@ This can be overwritten for different connection types in `tramp-methods'." This is necessary as self defense mechanism, in order to avoid yo-yo connection attempts when the remote host is unavailable. -A value of 0 or `nil' suppresses this check. This might be +A value of 0 or nil suppresses this check. This might be necessary, when several out-of-order copy operations are performed, or when several asynchronous processes will be started in a short time frame. In those cases it is recommended to @@ -1082,8 +1057,8 @@ A remote directory might have changed its contents. In order to make it visible during file name completion in the minibuffer, Tramp flushes its cache and rereads the directory contents when more than `tramp-completion-reread-directory-timeout' seconds -have been gone since last remote command execution. A value of `t' -would require an immediate reread during filename completion, `nil' +have been gone since last remote command execution. A value of t +would require an immediate reread during filename completion, nil means to use always cached values for the directory contents." :group 'tramp :type '(choice (const nil) (const t) integer)) @@ -1120,15 +1095,31 @@ calling HANDLER.") ;;; Internal functions which must come first: +(defsubst tramp-user-error (vec-or-proc format &rest args) + "Signal a pilot error." + (apply + 'tramp-error vec-or-proc + (if (fboundp 'user-error) 'user-error 'error) format args)) + ;; Conversion functions between external representation and ;; internal data structure. Convenience functions for internal ;; data structure. -(defun tramp-get-method-parameter (method param) +(defun tramp-get-method-parameter (vec param) "Return the method parameter PARAM. -If the `tramp-methods' entry does not exist, return nil." - (let ((entry (assoc param (assoc method tramp-methods)))) - (when entry (cadr entry)))) +If VEC is a vector, check first in connection properties. +Afterwards, check in `tramp-methods'. If the `tramp-methods' +entry does not exist, return nil." + (let ((hash-entry + (tramp-compat-replace-regexp-in-string + "^tramp-" "" (symbol-name param)))) + (if (tramp-connection-property-p vec hash-entry) + ;; We use the cached property. + (tramp-get-connection-property vec hash-entry nil) + ;; Use the static value from `tramp-methods'. + (let ((methods-entry + (assoc param (assoc (tramp-file-name-method vec) tramp-methods)))) + (when methods-entry (cadr methods-entry)))))) (defun tramp-file-name-p (vec) "Check, whether VEC is a Tramp object." @@ -1192,7 +1183,7 @@ If the `tramp-methods' entry does not exist, return nil." (or (and (stringp host) (string-match tramp-host-with-port-regexp host) (string-to-number (match-string 2 host))) - (tramp-get-method-parameter method 'tramp-default-port))))) + (tramp-get-method-parameter vec 'tramp-default-port))))) ;;;###tramp-autoload (defun tramp-tramp-file-p (name) @@ -1232,30 +1223,40 @@ their replacement." (if noninteractive (warn "Method %s is obsolete, using %s" result (substring result 0 -1)) - (unless (y-or-n-p (format "Method %s is obsolete, use %s? " + (unless (y-or-n-p (format "Method \"%s\" is obsolete, use \"%s\"? " result (substring result 0 -1))) - (tramp-compat-user-error "Method \"%s\" not supported" result))) + (tramp-user-error nil "Method \"%s\" not supported" result))) (add-to-list 'tramp-warned-obsolete-methods result)) ;; This works with the current set of `tramp-obsolete-methods'. ;; Must be improved, if their are more sophisticated replacements. (setq result (substring result 0 -1))) - result)) + ;; We must mark, whether a default value has been used. Not + ;; applicable for XEmacs. + (if (or method (null result) (null (functionp 'propertize))) + result + (tramp-compat-funcall 'propertize result 'tramp-default t)))) (defun tramp-find-user (method user host) "Return the right user string to use. This is USER, if non-nil. Otherwise, do a lookup in `tramp-default-user-alist'." - (or user - (let ((choices tramp-default-user-alist) - luser item) - (while choices - (setq item (pop choices)) - (when (and (string-match (or (nth 0 item) "") (or method "")) - (string-match (or (nth 1 item) "") (or host ""))) - (setq luser (nth 2 item)) - (setq choices nil))) - luser) - tramp-default-user)) + (let ((result + (or user + (let ((choices tramp-default-user-alist) + luser item) + (while choices + (setq item (pop choices)) + (when (and (string-match (or (nth 0 item) "") (or method "")) + (string-match (or (nth 1 item) "") (or host ""))) + (setq luser (nth 2 item)) + (setq choices nil))) + luser) + tramp-default-user))) + ;; We must mark, whether a default value has been used. Not + ;; applicable for XEmacs. + (if (or user (null result) (null (functionp 'propertize))) + result + (tramp-compat-funcall 'propertize result 'tramp-default t)))) (defun tramp-find-host (method user host) "Return the right host string to use. @@ -1272,6 +1273,22 @@ This is HOST, if non-nil. Otherwise, it is `tramp-default-host'." lhost) tramp-default-host)) +(defun tramp-check-proper-method-and-host (vec) + "Check method and host name of VEC." + (let ((method (tramp-file-name-method vec)) + (user (tramp-file-name-user vec)) + (host (tramp-file-name-host vec)) + (methods (mapcar 'car tramp-methods))) + (when (and method (not (member method methods))) + (tramp-cleanup-connection vec) + (tramp-user-error vec "Unknown method \"%s\"" method)) + (when (and (equal tramp-syntax 'ftp) host + (or (null method) (get-text-property 0 'tramp-default method)) + (or (null user) (get-text-property 0 'tramp-default user)) + (member host methods)) + (tramp-cleanup-connection vec) + (tramp-user-error vec "Host name must not match method \"%s\"" host)))) + (defun tramp-dissect-file-name (name &optional nodefault) "Return a `tramp-file-name' structure. The structure consists of remote method, remote user, remote host @@ -1280,7 +1297,7 @@ non-nil, the file name parts are not expanded to their default values." (save-match-data (let ((match (string-match (nth 0 tramp-file-name-structure) name))) - (unless match (tramp-compat-user-error "Not a Tramp file name: %s" name)) + (unless match (tramp-user-error nil "Not a Tramp file name: \"%s\"" name)) (let ((method (match-string (nth 1 tramp-file-name-structure) name)) (user (match-string (nth 2 tramp-file-name-structure) name)) (host (match-string (nth 3 tramp-file-name-structure) name)) @@ -1290,12 +1307,7 @@ values." (when (string-match tramp-prefix-ipv6-regexp host) (setq host (replace-match "" nil t host))) (when (string-match tramp-postfix-ipv6-regexp host) - (setq host (replace-match "" nil t host))) - (when (and (equal tramp-syntax 'ftp) (null method) (null user) - (member host (mapcar 'car tramp-methods)) - (not (tramp-completion-mode-p))) - (tramp-compat-user-error - "Host name must not match method `%s'" host))) + (setq host (replace-match "" nil t host)))) (if nodefault (vector method user host localname hop) (vector @@ -1429,66 +1441,70 @@ The outline level is equal to the verbosity of the Tramp message." "Append message to debug buffer. Message is formatted with FMT-STRING as control string and the remaining ARGUMENTS to actually emit the message (if applicable)." - (when (get-buffer (tramp-buffer-name vec)) - (with-current-buffer (tramp-get-debug-buffer vec) - (goto-char (point-max)) - ;; Headline. - (when (bobp) + (with-current-buffer (tramp-get-debug-buffer vec) + (goto-char (point-max)) + ;; Headline. + (when (bobp) + (insert + (format + ";; %sEmacs: %s Tramp: %s -*- mode: outline; -*-" + (if (featurep 'sxemacs) "SX" (if (featurep 'xemacs) "X" "GNU ")) + emacs-version tramp-version)) + (when (>= tramp-verbose 10) (insert (format - ";; %sEmacs: %s Tramp: %s -*- mode: outline; -*-" - (if (featurep 'sxemacs) "SX" (if (featurep 'xemacs) "X" "GNU ")) - emacs-version tramp-version))) - (unless (bolp) - (insert "\n")) - ;; Timestamp. - (let ((now (current-time))) - (insert (format-time-string "%T." now)) - (insert (format "%06d " (nth 2 now)))) - ;; Calling Tramp function. We suppress compat and trace - ;; functions from being displayed. - (let ((btn 1) btf fn) - (while (not fn) - (setq btf (nth 1 (backtrace-frame btn))) - (if (not btf) - (setq fn "") - (when (symbolp btf) - (setq fn (symbol-name btf)) - (unless - (and - (string-match "^tramp" fn) - (not - (string-match - (concat - "^" - (regexp-opt - '("tramp-backtrace" - "tramp-compat-condition-case-unless-debug" - "tramp-compat-funcall" - "tramp-compat-with-temp-message" - "tramp-condition-case-unless-debug" - "tramp-debug-message" - "tramp-error" - "tramp-error-with-buffer" - "tramp-message") - t) - "$") - fn))) - (setq fn nil))) - (setq btn (1+ btn)))) - ;; The following code inserts filename and line number. - ;; Should be inactive by default, because it is time - ;; consuming. -; (let ((ffn (find-function-noselect (intern fn)))) -; (insert -; (format -; "%s:%d: " -; (file-name-nondirectory (buffer-file-name (car ffn))) -; (with-current-buffer (car ffn) -; (1+ (count-lines (point-min) (cdr ffn))))))) - (insert (format "%s " fn))) - ;; The message. - (insert (apply 'format fmt-string arguments))))) + "\n;; Location: %s Git: %s" + (locate-library "tramp") (tramp-repository-get-version))))) + (unless (bolp) + (insert "\n")) + ;; Timestamp. + (let ((now (current-time))) + (insert (format-time-string "%T." now)) + (insert (format "%06d " (nth 2 now)))) + ;; Calling Tramp function. We suppress compat and trace functions + ;; from being displayed. + (let ((btn 1) btf fn) + (while (not fn) + (setq btf (nth 1 (backtrace-frame btn))) + (if (not btf) + (setq fn "") + (when (symbolp btf) + (setq fn (symbol-name btf)) + (unless + (and + (string-match "^tramp" fn) + (not + (string-match + (concat + "^" + (regexp-opt + '("tramp-backtrace" + "tramp-compat-condition-case-unless-debug" + "tramp-compat-funcall" + "tramp-compat-with-temp-message" + "tramp-condition-case-unless-debug" + "tramp-debug-message" + "tramp-error" + "tramp-error-with-buffer" + "tramp-message" + "tramp-user-error") + t) + "$") + fn))) + (setq fn nil))) + (setq btn (1+ btn)))) + ;; The following code inserts filename and line number. Should + ;; be inactive by default, because it is time consuming. +; (let ((ffn (find-function-noselect (intern fn)))) +; (insert +; (format +; "%s:%d: " +; (file-name-nondirectory (buffer-file-name (car ffn))) +; (with-current-buffer (car ffn) +; (1+ (count-lines (point-min) (cdr ffn))))))) + (insert (format "%s " fn))) + ;; The message. + (insert (apply #'format-message fmt-string arguments)))) (defvar tramp-message-show-message t "Show Tramp message in the minibuffer. @@ -1525,22 +1541,32 @@ applicable)." arguments)) ;; Log only when there is a minimum level. (when (>= tramp-verbose 4) - (when (and vec-or-proc - (processp vec-or-proc) - (buffer-name (process-buffer vec-or-proc))) - (with-current-buffer (process-buffer vec-or-proc) - ;; Translate proc to vec. - (setq vec-or-proc (tramp-dissect-file-name default-directory)))) - (when (and vec-or-proc (vectorp vec-or-proc)) + ;; Translate proc to vec. + (when (processp vec-or-proc) + (let ((tramp-verbose 0)) + (setq vec-or-proc + (tramp-get-connection-property vec-or-proc "vector" nil)))) + ;; Append connection buffer for error messages. + (when (= level 1) + (let ((tramp-verbose 0)) + (with-current-buffer (tramp-get-connection-buffer vec-or-proc) + (setq fmt-string (concat fmt-string "\n%s") + arguments (append arguments (list (buffer-string))))))) + ;; Do it. + (when (vectorp vec-or-proc) (apply 'tramp-debug-message vec-or-proc (concat (format "(%d) # " level) fmt-string) arguments))))))) -(defsubst tramp-backtrace (vec-or-proc) +(defsubst tramp-backtrace (&optional vec-or-proc) "Dump a backtrace into the debug buffer. -This function is meant for debugging purposes." - (tramp-message vec-or-proc 10 "\n%s" (with-output-to-string (backtrace)))) +If VEC-OR-PROC is nil, the buffer *debug tramp* is used. This +function is meant for debugging purposes." + (if vec-or-proc + (tramp-message vec-or-proc 10 "\n%s" (with-output-to-string (backtrace))) + (if (>= tramp-verbose 10) + (with-output-to-temp-buffer "*debug tramp*" (backtrace))))) (defsubst tramp-error (vec-or-proc signal fmt-string &rest arguments) "Emit an error. @@ -1549,13 +1575,14 @@ signal identifier to be raised, remaining arguments passed to `tramp-message'. Finally, signal SIGNAL is raised." (let (tramp-message-show-message) (tramp-backtrace vec-or-proc) - (tramp-message - vec-or-proc 1 "%s" - (error-message-string - (list signal - (get signal 'error-message) - (apply 'format fmt-string arguments)))) - (signal signal (list (apply 'format fmt-string arguments))))) + (when vec-or-proc + (tramp-message + vec-or-proc 1 "%s" + (error-message-string + (list signal + (get signal 'error-message) + (apply #'format-message fmt-string arguments))))) + (signal signal (list (apply #'format-message fmt-string arguments))))) (defsubst tramp-error-with-buffer (buf vec-or-proc signal fmt-string &rest arguments) @@ -1576,11 +1603,13 @@ an input event arrives. The other arguments are passed to `tramp-error'." (when (and buf tramp-message-show-message (not (zerop tramp-verbose)) - (not (tramp-completion-mode-p))) + (not (tramp-completion-mode-p)) + ;; Show only when Emacs has started already. + (current-message)) (let ((enable-recursive-minibuffers t)) ;; `tramp-error' does not show messages. So we must do it ;; ourselves. - (message fmt-string arguments) + (apply 'message fmt-string arguments) ;; Show buffer. (pop-to-buffer buf) (discard-input) @@ -1606,18 +1635,19 @@ Remaining args are Lisp expressions to be evaluated (inside an implicit If VAR is nil, then we bind `v' to the structure and `method', `user', `host', `localname', `hop' to the components." - `(let* ((,(or var 'v) (tramp-dissect-file-name ,filename)) - (,(if var (intern (concat (symbol-name var) "-method")) 'method) - (tramp-file-name-method ,(or var 'v))) - (,(if var (intern (concat (symbol-name var) "-user")) 'user) - (tramp-file-name-user ,(or var 'v))) - (,(if var (intern (concat (symbol-name var) "-host")) 'host) - (tramp-file-name-host ,(or var 'v))) - (,(if var (intern (concat (symbol-name var) "-localname")) 'localname) - (tramp-file-name-localname ,(or var 'v))) - (,(if var (intern (concat (symbol-name var) "-hop")) 'hop) - (tramp-file-name-hop ,(or var 'v)))) - ,@body)) + (let ((bindings + (mapcar (lambda (elem) + `(,(if var (intern (format "%s-%s" var elem)) elem) + (,(intern (format "tramp-file-name-%s" elem)) + ,(or var 'v)))) + '(method user host localname hop)))) + `(let* ((,(or var 'v) (tramp-dissect-file-name ,filename)) + ,@bindings) + ;; We don't know which of those vars will be used, so we bind them all, + ;; and then add here a dummy use of all those variables, so we don't get + ;; flooded by warnings about those vars `body' didn't use. + (ignore ,@(mapcar #'car bindings)) + ,@body))) (put 'with-parsed-tramp-file-name 'lisp-indent-function 2) (put 'with-parsed-tramp-file-name 'edebug-form-spec '(form symbolp body)) @@ -1635,24 +1665,27 @@ If VAR is nil, then we bind `v' to the structure and `method', `user', If LEVEL does not fit for visible messages, there are only traces without a visible progress reporter." (declare (indent 3) (debug t)) - `(let ((result "failed") - pr tm) + `(progn (tramp-message ,vec ,level "%s..." ,message) - ;; We start a pulsing progress reporter after 3 seconds. Feature - ;; introduced in Emacs 24.1. - (when (and tramp-message-show-message - ;; Display only when there is a minimum level. - (<= ,level (min tramp-verbose 3))) - (ignore-errors - (setq pr (tramp-compat-funcall 'make-progress-reporter ,message) - tm (when pr - (run-at-time 3 0.1 'tramp-progress-reporter-update pr))))) - (unwind-protect - ;; Execute the body. - (prog1 (progn ,@body) (setq result "done")) - ;; Stop progress reporter. - (if tm (tramp-compat-funcall 'cancel-timer tm)) - (tramp-message ,vec ,level "%s...%s" ,message result)))) + (let ((cookie "failed") + (tm + ;; We start a pulsing progress reporter after 3 seconds. Feature + ;; introduced in Emacs 24.1. + (when (and tramp-message-show-message + ;; Display only when there is a minimum level. + (<= ,level (min tramp-verbose 3))) + (ignore-errors + (let ((pr (tramp-compat-funcall + #'make-progress-reporter ,message))) + (when pr + (run-at-time 3 0.1 + #'tramp-progress-reporter-update pr))))))) + (unwind-protect + ;; Execute the body. + (prog1 (progn ,@body) (setq cookie "done")) + ;; Stop progress reporter. + (if tm (tramp-compat-funcall 'cancel-timer tm)) + (tramp-message ,vec ,level "%s...%s" ,message cookie))))) (tramp-compat-font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-progress-reporter\\>")) @@ -1703,19 +1736,6 @@ letter into the file name. This function removes it." (replace-match "/" nil t name) name))) -(defun tramp-cleanup (vec) - "Cleanup connection VEC, but keep the debug buffer." - (with-current-buffer (tramp-get-debug-buffer vec) - ;; Keep the debug buffer. - (rename-buffer - (generate-new-buffer-name tramp-temp-buffer-name) 'unique) - (tramp-cleanup-connection vec) - (if (= (point-min) (point-max)) - (kill-buffer nil) - (rename-buffer (tramp-debug-buffer-name vec) 'unique)) - ;; We call `tramp-get-buffer' in order to keep the debug buffer. - (tramp-get-buffer vec))) - ;;; Config Manipulation Functions: ;;;###tramp-autoload @@ -1730,7 +1750,7 @@ Example: (tramp-set-completion-function \"ssh\" - '((tramp-parse-sconfig \"/etc/ssh_config\") + \\='((tramp-parse-sconfig \"/etc/ssh_config\") (tramp-parse-sconfig \"~/.ssh/config\")))" (let ((r function-list) @@ -1750,7 +1770,7 @@ Example: (and (memq system-type '(cygwin windows-nt)) (zerop (tramp-call-process - "reg" nil nil nil "query" (nth 1 (car v))))) + v "reg" nil nil nil "query" (nth 1 (car v))))) ;; Configuration file. (file-exists-p (nth 1 (car v))))) (setq r (delete (car v) r))) @@ -1821,7 +1841,7 @@ been set up by `rfn-eshadow-setup-minibuffer'." ;; We do not want to send any remote command. (non-essential t)) (when - (file-remote-p + (tramp-tramp-file-p (tramp-compat-funcall 'buffer-substring-no-properties end (point-max))) (save-excursion @@ -1932,8 +1952,7 @@ coding system might not be determined. This function repairs it." (add-to-list 'result (cons (regexp-quote tmpname) (cdr elt)) 'append))))) -;;;###autoload -(progn (defun tramp-run-real-handler (operation args) +(defun tramp-run-real-handler (operation args) "Invoke normal file name handler for OPERATION. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." @@ -1947,7 +1966,7 @@ pass to the OPERATION." ,(and (eq inhibit-file-name-operation operation) inhibit-file-name-handlers))) (inhibit-file-name-operation operation)) - (apply operation args)))) + (apply operation args))) ;;;###autoload (progn (defun tramp-completion-run-real-handler (operation args) @@ -2022,8 +2041,8 @@ ARGS are the arguments OPERATION has been called with." 'vm-imap-move-mail 'vm-pop-move-mail 'vm-spool-move-mail)) (save-match-data (cond - ((string-match tramp-file-name-regexp (nth 0 args)) (nth 0 args)) - ((string-match tramp-file-name-regexp (nth 1 args)) (nth 1 args)) + ((tramp-tramp-file-p (nth 0 args)) (nth 0 args)) + ((tramp-tramp-file-p (nth 1 args)) (nth 1 args)) (t (buffer-file-name (current-buffer)))))) ;; START END FILE. ((eq operation 'write-region) @@ -2051,7 +2070,7 @@ ARGS are the arguments OPERATION has been called with." 'dired-print-file 'dired-shell-call-process)) default-directory) ;; PROC. - ((eq operation 'file-notify-rm-watch) + ((member operation (list 'file-notify-rm-watch 'file-notify-valid-p)) (when (processp (nth 0 args)) (with-current-buffer (process-buffer (nth 0 args)) default-directory))) @@ -2089,7 +2108,6 @@ ARGS are the arguments OPERATION has been called with." (tramp-compat-condition-case-unless-debug ,var ,bodyform ,@handlers))) ;; Main function. -;;;###autoload (defun tramp-file-name-handler (operation &rest args) "Invoke Tramp file name handler. Falls back to normal file name handler if no Tramp file name handler exists." @@ -2131,14 +2149,14 @@ Falls back to normal file name handler if no Tramp file name handler exists." ((eq result 'non-essential) (tramp-message v 5 "Non-essential received in operation %s" - (append (list operation) args)) + (cons operation args)) (tramp-run-real-handler operation args)) ((eq result 'suppress) (let (tramp-message-show-message) (tramp-message v 1 "Suppress received in operation %s" - (append (list operation) args)) - (tramp-cleanup v) + (cons operation args)) + (tramp-cleanup-connection v t) (tramp-run-real-handler operation args))) (t result))) @@ -2147,7 +2165,7 @@ Falls back to normal file name handler if no Tramp file name handler exists." (let (tramp-message-show-message) (tramp-message v 1 "Interrupt received in operation %s" - (append (list operation) args))) + (cons operation args))) ;; Propagate the quit signal. (signal (car err) (cdr err))) @@ -2232,15 +2250,44 @@ Falls back to normal file name handler if no Tramp file name handler exists." (tramp-completion-run-real-handler operation args))))) ;;;###autoload -(progn (defun tramp-register-file-name-handlers () +(progn (defun tramp-autoload-file-name-handler (operation &rest args) + "Load Tramp file name handler, and perform OPERATION." + ;; Avoid recursive loading of tramp.el. `temporary-file-directory' + ;; does not exist in XEmacs, so we must use something else. + (let ((default-directory "/")) + (load "tramp" nil t)) + (apply operation args))) + +;; `tramp-autoload-file-name-handler' must be registered before +;; evaluation of site-start and init files, because there might exist +;; remote files already, f.e. files kept via recentf-mode. We cannot +;; autoload `tramp-file-name-handler', because it would result in +;; recursive loading of tramp.el when `default-directory' is set to +;; remote. +;;;###autoload +(progn (defun tramp-register-autoload-file-name-handlers () + "Add Tramp file name handlers to `file-name-handler-alist' during autoload." + (add-to-list 'file-name-handler-alist + (cons tramp-file-name-regexp + 'tramp-autoload-file-name-handler)) + (put 'tramp-autoload-file-name-handler 'safe-magic t) + (add-to-list 'file-name-handler-alist + (cons tramp-completion-file-name-regexp + 'tramp-completion-file-name-handler)) + (put 'tramp-completion-file-name-handler 'safe-magic t))) + +;;;###autoload +(tramp-register-autoload-file-name-handlers) + +(defun tramp-register-file-name-handlers () "Add Tramp file name handlers to `file-name-handler-alist'." ;; Remove autoloaded handlers from file name handler alist. Useful, ;; if `tramp-syntax' has been changed. - (let ((a1 (rassq 'tramp-file-name-handler file-name-handler-alist))) - (setq file-name-handler-alist (delq a1 file-name-handler-alist))) - (let ((a1 (rassq - 'tramp-completion-file-name-handler file-name-handler-alist))) - (setq file-name-handler-alist (delq a1 file-name-handler-alist))) + (dolist (fnh '(tramp-file-name-handler + tramp-completion-file-name-handler + tramp-autoload-file-name-handler)) + (let ((a1 (rassq fnh file-name-handler-alist))) + (setq file-name-handler-alist (delq a1 file-name-handler-alist)))) ;; Add the handlers. (add-to-list 'file-name-handler-alist (cons tramp-file-name-regexp 'tramp-file-name-handler)) @@ -2255,13 +2302,9 @@ Falls back to normal file name handler if no Tramp file name handler exists." (let ((entry (rassoc fnh file-name-handler-alist))) (when entry (setq file-name-handler-alist - (cons entry (delete entry file-name-handler-alist)))))))) + (cons entry (delete entry file-name-handler-alist))))))) -;; `tramp-file-name-handler' must be registered before evaluation of -;; site-start and init files, because there might exist remote files -;; already, f.e. files kept via recentf-mode. -;;;###autoload -(tramp-register-file-name-handlers) +(eval-after-load 'tramp (tramp-register-file-name-handlers)) (defun tramp-exists-file-name-handler (operation &rest args) "Check, whether OPERATION runs a file name handler." @@ -2356,7 +2399,8 @@ not in completion mode." (and (tramp-tramp-file-p filename) (with-parsed-tramp-file-name filename nil (or (not (tramp-completion-mode-p)) - (let ((p (tramp-get-connection-process v))) + (let* ((tramp-verbose 0) + (p (tramp-get-connection-process v))) (and p (processp p) (memq (process-status p) '(run open)))))))) ;; Method, host name and user name completion. @@ -2512,64 +2556,40 @@ They are collected by `tramp-completion-dissect-file-name1'." tramp-prefix-ipv6-regexp "\\(" tramp-completion-ipv6-regexp x-nil "\\)$") nil 1 2 nil)) - ;; "/method:user" "/[method/user" "/method://user" + ;; "/method:user" "/[method/user" (tramp-completion-file-name-structure7 (list (concat tramp-prefix-regexp "\\(" tramp-method-regexp "\\)" tramp-postfix-method-regexp "\\(" tramp-user-regexp x-nil "\\)$") 1 2 nil nil)) - ;; "/method:host" "/[method/host" "/method://host" + ;; "/method:host" "/[method/host" (tramp-completion-file-name-structure8 (list (concat tramp-prefix-regexp "\\(" tramp-method-regexp "\\)" tramp-postfix-method-regexp "\\(" tramp-host-regexp x-nil "\\)$") 1 nil 2 nil)) - ;; "/method:[ipv6" "/[method/ipv6" "/method://[ipv6" + ;; "/method:[ipv6" "/[method/ipv6" (tramp-completion-file-name-structure9 (list (concat tramp-prefix-regexp "\\(" tramp-method-regexp "\\)" tramp-postfix-method-regexp tramp-prefix-ipv6-regexp "\\(" tramp-completion-ipv6-regexp x-nil "\\)$") 1 nil 2 nil)) - ;; "/method:user@host" "/[method/user@host" "/method://user@host" + ;; "/method:user@host" "/[method/user@host" (tramp-completion-file-name-structure10 (list (concat tramp-prefix-regexp "\\(" tramp-method-regexp "\\)" tramp-postfix-method-regexp "\\(" tramp-user-regexp "\\)" tramp-postfix-user-regexp "\\(" tramp-host-regexp x-nil "\\)$") 1 2 3 nil)) - ;; "/method:user@[ipv6" "/[method/user@ipv6" "/method://user@[ipv6" + ;; "/method:user@[ipv6" "/[method/user@ipv6" (tramp-completion-file-name-structure11 (list (concat tramp-prefix-regexp "\\(" tramp-method-regexp "\\)" tramp-postfix-method-regexp "\\(" tramp-user-regexp "\\)" tramp-postfix-user-regexp tramp-prefix-ipv6-regexp "\\(" tramp-completion-ipv6-regexp x-nil "\\)$") - 1 2 3 nil)) - ;; "/method: "/method:/" - (tramp-completion-file-name-structure12 - (list - (if (equal tramp-syntax 'url) - (concat tramp-prefix-regexp - "\\(" tramp-method-regexp "\\)" - "\\(" (substring tramp-postfix-method-regexp 0 1) - "\\|" (substring tramp-postfix-method-regexp 1 2) "\\)" - "\\(" "\\)$") - ;; Should not match if not URL syntax. - (concat tramp-prefix-regexp "/$")) - 1 3 nil nil)) - ;; "/method: "/method:/" - (tramp-completion-file-name-structure13 - (list - (if (equal tramp-syntax 'url) - (concat tramp-prefix-regexp - "\\(" tramp-method-regexp "\\)" - "\\(" (substring tramp-postfix-method-regexp 0 1) - "\\|" (substring tramp-postfix-method-regexp 1 2) "\\)" - "\\(" "\\)$") - ;; Should not match if not URL syntax. - (concat tramp-prefix-regexp "/$")) - 1 nil 3 nil))) + 1 2 3 nil))) (mapc (lambda (structure) (add-to-list 'result @@ -2586,8 +2606,6 @@ They are collected by `tramp-completion-dissect-file-name1'." tramp-completion-file-name-structure9 tramp-completion-file-name-structure10 tramp-completion-file-name-structure11 - tramp-completion-file-name-structure12 - tramp-completion-file-name-structure13 tramp-file-name-structure)) (delq nil result))) @@ -2807,7 +2825,7 @@ User is always nil." (if (memq system-type '(windows-nt)) (with-temp-buffer (when (zerop (tramp-call-process - "reg" nil t nil "query" registry-or-dirname)) + nil "reg" nil t nil "query" registry-or-dirname)) (goto-char (point-min)) (loop while (not (eobp)) collect (tramp-parse-putty-group registry-or-dirname)))) @@ -2886,7 +2904,7 @@ User is always nil." (defun tramp-handle-file-accessible-directory-p (filename) "Like `file-accessible-directory-p' for Tramp files." (and (file-directory-p filename) - (file-executable-p filename))) + (file-readable-p filename))) (defun tramp-handle-file-exists-p (filename) "Like `file-exists-p' for Tramp files." @@ -2910,7 +2928,8 @@ User is always nil." (tramp-file-name-user v) (tramp-file-name-host v) (tramp-run-real-handler - 'file-name-as-directory (list (or (tramp-file-name-localname v) "")))))) + 'file-name-as-directory (list (or (tramp-file-name-localname v) ""))) + (tramp-file-name-hop v)))) (defun tramp-handle-file-name-completion (filename directory &optional predicate) @@ -2938,7 +2957,8 @@ User is always nil." (tramp-file-name-user v) (tramp-file-name-host v) (tramp-run-real-handler - 'file-name-directory (list (or (tramp-file-name-localname v) "")))))) + 'file-name-directory (list (or (tramp-file-name-localname v) ""))) + (tramp-file-name-hop v)))) (defun tramp-handle-file-name-nondirectory (file) "Like `file-name-nondirectory' but aware of Tramp files." @@ -2950,8 +2970,8 @@ User is always nil." (cond ((not (file-exists-p file1)) nil) ((not (file-exists-p file2)) t) - (t (tramp-time-less-p (nth 5 (file-attributes file2)) - (nth 5 (file-attributes file1)))))) + (t (time-less-p (nth 5 (file-attributes file2)) + (nth 5 (file-attributes file1)))))) (defun tramp-handle-file-regular-p (filename) "Like `file-regular-p' for Tramp files." @@ -2960,7 +2980,8 @@ User is always nil." (defun tramp-handle-file-remote-p (filename &optional identification connected) "Like `file-remote-p' for Tramp files." - (let ((tramp-verbose 3)) + ;; We do not want traces in the debug buffer. + (let ((tramp-verbose (min tramp-verbose 3))) (when (tramp-tramp-file-p filename) (let* ((v (tramp-dissect-file-name filename)) (p (tramp-get-connection-process v)) @@ -2974,15 +2995,14 @@ User is always nil." ((eq identification 'user) user) ((eq identification 'host) host) ((eq identification 'localname) localname) - (t (tramp-make-tramp-file-name method user host ""))))))))) + ((eq identification 'hop) hop) + (t (tramp-make-tramp-file-name method user host "" hop))))))))) (defun tramp-handle-file-symlink-p (filename) "Like `file-symlink-p' for Tramp files." (with-parsed-tramp-file-name filename nil (let ((x (car (file-attributes filename)))) (when (stringp x) - ;; When Tramp is running on VMS, then `file-name-absolute-p' - ;; might do weird things. (if (file-name-absolute-p x) (tramp-make-tramp-file-name method user host x) x))))) @@ -3029,6 +3049,38 @@ User is always nil." (tramp-run-real-handler 'find-backup-file-name (list filename))))) +(defun tramp-handle-insert-directory + (filename switches &optional wildcard full-directory-p) + "Like `insert-directory' for Tramp files." + (unless switches (setq switches "")) + ;; Mark trailing "/". + (when (and (zerop (length (file-name-nondirectory filename))) + (not full-directory-p)) + (setq switches (concat switches "F"))) + (with-parsed-tramp-file-name (expand-file-name filename) nil + (with-tramp-progress-reporter v 0 (format "Opening directory %s" filename) + (require 'ls-lisp) + (let (ls-lisp-use-insert-directory-program start) + (tramp-run-real-handler + 'insert-directory + (list filename switches wildcard full-directory-p)) + ;; `ls-lisp' always returns full listings. We must remove + ;; superfluous parts. + (unless (string-match "l" switches) + (save-excursion + (goto-char (point-min)) + (while (setq start + (text-property-not-all + (point) (point-at-eol) 'dired-filename t)) + (delete-region + start + (or (text-property-any start (point-at-eol) 'dired-filename t) + (point-at-eol))) + (if (= (point-at-bol) (point-at-eol)) + ;; Empty line. + (delete-region (point) (progn (forward-line) (point))) + (forward-line))))))))) + (defun tramp-handle-insert-file-contents (filename &optional visit beg end replace) "Like `insert-file-contents' for Tramp files." @@ -3036,108 +3088,118 @@ User is always nil." (setq filename (expand-file-name filename)) (let (result local-copy remote-copy) (with-parsed-tramp-file-name filename nil - (with-tramp-progress-reporter - v 3 (format "Inserting `%s'" filename) - (unwind-protect - (if (not (file-exists-p filename)) - ;; We don't raise a Tramp error, because it might be - ;; suppressed, like in `find-file-noselect-1'. - (signal 'file-error - (list "File not found on remote host" filename)) - - (if (and (tramp-local-host-p v) - (let (file-name-handler-alist) - (file-readable-p localname))) - ;; Short track: if we are on the local host, we can - ;; run directly. - (setq result - (tramp-run-real-handler - 'insert-file-contents - (list localname visit beg end replace))) - - ;; When we shall insert only a part of the file, we - ;; copy this part. - (when (or beg end) - (setq remote-copy (tramp-make-tramp-temp-file v)) - ;; This is defined in tramp-sh.el. Let's assume - ;; this is loaded already. - (tramp-compat-funcall - 'tramp-send-command - v - (cond - ((and beg end) - (format "dd bs=1 skip=%d if=%s count=%d of=%s" - beg (tramp-shell-quote-argument localname) - (- end beg) remote-copy)) - (beg - (format "dd bs=1 skip=%d if=%s of=%s" - beg (tramp-shell-quote-argument localname) - remote-copy)) - (end - (format "dd bs=1 count=%d if=%s of=%s" - end (tramp-shell-quote-argument localname) - remote-copy))))) - - ;; `insert-file-contents-literally' takes care to - ;; avoid calling jka-compr. By let-binding - ;; `inhibit-file-name-operation', we propagate that - ;; care to the `file-local-copy' operation. - (setq local-copy - (let ((inhibit-file-name-operation - (when (eq inhibit-file-name-operation - 'insert-file-contents) - 'file-local-copy))) - (cond - ((stringp remote-copy) - (file-local-copy - (tramp-make-tramp-file-name - method user host remote-copy))) - ((stringp tramp-temp-buffer-file-name) - (copy-file filename tramp-temp-buffer-file-name 'ok) - tramp-temp-buffer-file-name) - (t (file-local-copy filename))))) - - ;; When the file is not readable for the owner, it - ;; cannot be inserted, even if it is readable for the - ;; group or for everybody. - (set-file-modes - local-copy (tramp-compat-octal-to-decimal "0600")) - - (when (and (null remote-copy) - (tramp-get-method-parameter - method 'tramp-copy-keep-tmpfile)) - ;; We keep the local file for performance reasons, - ;; useful for "rsync". - (setq tramp-temp-buffer-file-name local-copy)) - - ;; We must ensure that `file-coding-system-alist' - ;; matches `local-copy'. We must also use `visit', - ;; otherwise there might be an error in the - ;; `revert-buffer' function under XEmacs. - (let ((file-coding-system-alist - (tramp-find-file-name-coding-system-alist - filename local-copy))) - (setq result - (insert-file-contents - local-copy visit nil nil replace))))) - - ;; Save exit. - (progn - (when visit - (setq buffer-file-name filename) - (setq buffer-read-only (not (file-writable-p filename))) - (set-visited-file-modtime) - (set-buffer-modified-p nil)) - (when (and (stringp local-copy) - (or remote-copy (null tramp-temp-buffer-file-name))) - (delete-file local-copy)) - (when (stringp remote-copy) - (delete-file - (tramp-make-tramp-file-name method user host remote-copy))))))) - - ;; Result. - (list (expand-file-name filename) - (cadr result)))) + (unwind-protect + (if (not (file-exists-p filename)) + (tramp-error + v 'file-error "File `%s' not found on remote host" filename) + + (with-tramp-progress-reporter + v 3 (format-message "Inserting `%s'" filename) + (condition-case err + (if (and (tramp-local-host-p v) + (let (file-name-handler-alist) + (file-readable-p localname))) + ;; Short track: if we are on the local host, we can + ;; run directly. + (setq result + (tramp-run-real-handler + 'insert-file-contents + (list localname visit beg end replace))) + + ;; When we shall insert only a part of the file, we + ;; copy this part. This works only for the shell file + ;; name handlers. + (when (and (or beg end) + (tramp-get-method-parameter + v 'tramp-login-program)) + (setq remote-copy (tramp-make-tramp-temp-file v)) + ;; This is defined in tramp-sh.el. Let's assume + ;; this is loaded already. + (tramp-compat-funcall + 'tramp-send-command + v + (cond + ((and beg end) + (format "dd bs=1 skip=%d if=%s count=%d of=%s" + beg (tramp-shell-quote-argument localname) + (- end beg) remote-copy)) + (beg + (format "dd bs=1 skip=%d if=%s of=%s" + beg (tramp-shell-quote-argument localname) + remote-copy)) + (end + (format "dd bs=1 count=%d if=%s of=%s" + end (tramp-shell-quote-argument localname) + remote-copy)))) + (setq tramp-temp-buffer-file-name nil beg nil end nil)) + + ;; `insert-file-contents-literally' takes care to + ;; avoid calling jka-compr.el and epa.el. By + ;; let-binding `inhibit-file-name-operation', we + ;; propagate that care to the `file-local-copy' + ;; operation. + (setq local-copy + (let ((inhibit-file-name-operation + (when (eq inhibit-file-name-operation + 'insert-file-contents) + 'file-local-copy))) + (cond + ((stringp remote-copy) + (file-local-copy + (tramp-make-tramp-file-name + method user host remote-copy))) + ((stringp tramp-temp-buffer-file-name) + (copy-file + filename tramp-temp-buffer-file-name 'ok) + tramp-temp-buffer-file-name) + (t (file-local-copy filename))))) + + ;; When the file is not readable for the owner, it + ;; cannot be inserted, even if it is readable for the + ;; group or for everybody. + (set-file-modes + local-copy (tramp-compat-octal-to-decimal "0600")) + + (when (and (null remote-copy) + (tramp-get-method-parameter + v 'tramp-copy-keep-tmpfile)) + ;; We keep the local file for performance reasons, + ;; useful for "rsync". + (setq tramp-temp-buffer-file-name local-copy)) + + ;; We must ensure that `file-coding-system-alist' + ;; matches `local-copy'. We must also use `visit', + ;; otherwise there might be an error in the + ;; `revert-buffer' function under XEmacs. + (let ((file-coding-system-alist + (tramp-find-file-name-coding-system-alist + filename local-copy))) + (setq result + (insert-file-contents + local-copy visit beg end replace)))) + (error + (add-hook 'find-file-not-found-functions + `(lambda () (signal ',(car err) ',(cdr err))) + nil t) + (signal (car err) (cdr err)))))) + + ;; Save exit. + (progn + (when visit + (setq buffer-file-name filename) + (setq buffer-read-only (not (file-writable-p filename))) + (set-visited-file-modtime) + (set-buffer-modified-p nil)) + (when (and (stringp local-copy) + (or remote-copy (null tramp-temp-buffer-file-name))) + (delete-file local-copy)) + (when (stringp remote-copy) + (delete-file + (tramp-make-tramp-file-name method user host remote-copy))))) + + ;; Result. + (list (expand-file-name filename) + (cadr result))))) (defun tramp-handle-load (file &optional noerror nomessage nosuffix must-suffix) "Like `load' for Tramp files." @@ -3163,12 +3225,18 @@ User is always nil." (let ((tramp-message-show-message (not nomessage))) (with-tramp-progress-reporter v 0 (format "Loading %s" file) (let ((local-copy (file-local-copy file))) - ;; MUST-SUFFIX doesn't exist on XEmacs, so let it default to nil. (unwind-protect - (load local-copy noerror t t) + (tramp-compat-load local-copy noerror t nosuffix must-suffix) (delete-file local-copy))))) t))) +(defun tramp-handle-make-symbolic-link + (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 + (tramp-error v 'file-error "make-symbolic-link not supported"))) + (defun tramp-handle-shell-command (command &optional output-buffer error-buffer) "Like `shell-command' for Tramp files." @@ -3178,12 +3246,10 @@ User is always nil." (args (append (cons (tramp-get-method-parameter - (tramp-file-name-method - (tramp-dissect-file-name default-directory)) + (tramp-dissect-file-name default-directory) 'tramp-remote-shell) (tramp-get-method-parameter - (tramp-file-name-method - (tramp-dissect-file-name default-directory)) + (tramp-dissect-file-name default-directory) 'tramp-remote-shell-args)) (list (substring command 0 asynchronous)))) current-buffer-p @@ -3214,7 +3280,7 @@ User is always nil." (when p (if (yes-or-no-p "A command is running. Kill it? ") (ignore-errors (kill-process p)) - (tramp-compat-user-error "Shell command in progress"))) + (tramp-user-error p "Shell command in progress"))) (if current-buffer-p (progn @@ -3229,11 +3295,12 @@ User is always nil." ;; Run the process. (setq p (apply 'start-file-process "*Async Shell*" buffer args)) ;; Display output. - (pop-to-buffer output-buffer) - (setq mode-line-process '(":%s")) - (shell-mode) - (set-process-sentinel p 'shell-command-sentinel) - (set-process-filter p 'comint-output-filter)) + (with-current-buffer output-buffer + (display-buffer output-buffer '(nil (allow-no-window . t))) + (setq mode-line-process '(":%s")) + (shell-mode) + (set-process-sentinel p 'shell-command-sentinel) + (set-process-filter p 'comint-output-filter))) (prog1 ;; Run the process. @@ -3259,41 +3326,29 @@ User is always nil." (defun tramp-handle-substitute-in-file-name (filename) "Like `substitute-in-file-name' for Tramp files. -\"//\" and \"/~\" substitute only in the local filename part. -If the URL Tramp syntax is chosen, \"//\" as method delimiter and \"/~\" at -beginning of local filename are not substituted." +\"//\" and \"/~\" substitute only in the local filename part." ;; First, we must replace environment variables. (setq filename (tramp-replace-environment-variables filename)) (with-parsed-tramp-file-name filename nil - (if (equal tramp-syntax 'url) - ;; We need to check localname only. The other parts cannot contain - ;; "//" or "/~". - (if (and (> (length localname) 1) - (or (string-match "//" localname) - (string-match "/~" localname 1))) - (tramp-run-real-handler 'substitute-in-file-name (list filename)) - (tramp-make-tramp-file-name - (when method (substitute-in-file-name method)) - (when user (substitute-in-file-name user)) - (when host (substitute-in-file-name host)) - (when localname - (tramp-run-real-handler - 'substitute-in-file-name (list localname))))) - ;; Ignore in LOCALNAME everything before "//" or "/~". - (when (and (stringp localname) (string-match ".+?/\\(/\\|~\\)" localname)) - (setq filename - (concat (file-remote-p filename) - (replace-match "\\1" nil nil localname))) - ;; "/m:h:~" does not work for completion. We use "/m:h:~/". - (when (string-match "~$" filename) - (setq filename (concat filename "/")))) + ;; Ignore in LOCALNAME everything before "//" or "/~". + (when (and (stringp localname) (string-match ".+?/\\(/\\|~\\)" localname)) + (setq filename + (concat (file-remote-p filename) + (replace-match "\\1" nil nil localname))) + ;; "/m:h:~" does not work for completion. We use "/m:h:~/". + (when (string-match "~$" filename) + (setq filename (concat filename "/")))) + ;; We do not want to replace environment variables, again. + (let (process-environment) (tramp-run-real-handler 'substitute-in-file-name (list filename))))) (defun tramp-handle-unhandled-file-name-directory (_filename) "Like `unhandled-file-name-directory' for Tramp files." - ;; With Emacs 23, we could simply return `nil'. But we must keep it - ;; for backward compatibility. - (expand-file-name "~/")) + ;; Starting with Emacs 23, we must simply return nil. But we must + ;; keep backward compatibility, also with XEmacs. "~/" cannot be + ;; returned, because there might be machines without a HOME + ;; directory (like hydra). + (and (< emacs-major-version 23) "/")) (defun tramp-handle-set-visited-file-modtime (&optional time-list) "Like `set-visited-file-modtime' for Tramp files." @@ -3352,7 +3407,7 @@ of." (defun tramp-handle-file-notify-add-watch (filename _flags _callback) "Like `file-notify-add-watch' for Tramp files." ;; This is the default handler. tramp-gvfs.el and tramp-sh.el have - ;; its own one. + ;; their own one. (setq filename (expand-file-name filename)) (with-parsed-tramp-file-name filename nil (tramp-error @@ -3361,10 +3416,20 @@ of." (defun tramp-handle-file-notify-rm-watch (proc) "Like `file-notify-rm-watch' for Tramp files." ;; The descriptor must be a process object. - (unless (and (processp proc) (gethash proc file-notify-descriptors)) + (unless (processp proc) (tramp-error proc 'file-notify-error "Not a valid descriptor %S" proc)) (tramp-message proc 6 "Kill %S" proc) - (kill-process proc)) + (delete-process proc)) + +(defun tramp-handle-file-notify-valid-p (proc) + "Like `file-notify-valid-p' for Tramp files." + (and proc (processp proc) (memq (process-status proc) '(run open)) + ;; Sometimes, the process is still in status `run' when the + ;; file or directory to be watched is deleted already. + (with-current-buffer (process-buffer proc) + (file-exists-p + (concat (file-remote-p default-directory) + (tramp-compat-process-get proc 'watch-name)))))) ;;; Functions for establishing connection: @@ -3389,7 +3454,14 @@ of." (defun tramp-action-password (proc vec) "Query the user for a password." (with-current-buffer (process-buffer proc) - (let ((enable-recursive-minibuffers t)) + (let ((enable-recursive-minibuffers t) + (case-fold-search t)) + ;; Let's check whether a wrong password has been sent already. + ;; Sometimes, the process returns a new password request + ;; immediately after rejecting the previous (wrong) one. + (unless (tramp-get-connection-property vec "first-password-request" nil) + (tramp-clear-passwd vec)) + (goto-char (point-min)) (tramp-check-for-regexp proc tramp-password-prompt-regexp) (tramp-message vec 3 "Sending %s" (match-string 1)) ;; We don't call `tramp-send-string' in order to hide the @@ -3451,6 +3523,8 @@ The terminal type can be configured with `tramp-terminal-type'." (defun tramp-action-out-of-band (proc vec) "Check, whether an out-of-band copy has finished." + ;; There might be pending output for the exit status. + (tramp-accept-process-output proc 0.1) (cond ((and (memq (process-status proc) '(stop exit)) (zerop (process-exit-status proc))) (tramp-message vec 3 "Process has finished.") @@ -3475,7 +3549,8 @@ The terminal type can be configured with `tramp-terminal-type'." (defun tramp-process-one-action (proc vec actions) "Wait for output from the shell and perform one action." - (let (found todo item pattern action) + (let ((case-fold-search t) + found todo item pattern action) (while (not found) ;; Reread output once all actions have been performed. ;; Obviously, the output was not complete. @@ -3497,8 +3572,8 @@ The terminal type can be configured with `tramp-terminal-type'." PROC and VEC indicate the remote connection to be used. POS, if set, is the starting point of the region to be deleted in the connection buffer." - ;; Enable `auth-source' and `password-cache'. We must use - ;; tramp-current-* variables in case we have several hops. + ;; Enable `auth-source'. We must use tramp-current-* variables in + ;; case we have several hops. (tramp-set-connection-property (tramp-dissect-file-name (tramp-make-tramp-file-name @@ -3529,11 +3604,12 @@ connection buffer." (cond ((eq exit 'permission-denied) "Permission denied") ((eq exit 'process-died) - (concat - "Tramp failed to connect. If this happens repeatedly, try\n" - " `M-x tramp-cleanup-this-connection'")) + (substitute-command-keys + (concat + "Tramp failed to connect. If this happens repeatedly, try\n" + " `\\[tramp-cleanup-this-connection]'"))) ((eq exit 'timeout) - (format + (format-message "Timeout reached, see buffer `%s' for details" (tramp-get-connection-buffer vec))) (t "Login failed"))))) @@ -3548,15 +3624,19 @@ connection buffer." This is needed in order to hide `last-coding-system-used', which is set for process communication also." (with-current-buffer (process-buffer proc) - (tramp-message proc 10 "%s %s" proc (process-status proc)) - (let (buffer-read-only last-coding-system-used) + ;; FIXME: If there is a gateway process, we need communication + ;; between several processes. Too complicate to implement, so we + ;; read output from all processes. + (let ((p (if (tramp-get-connection-property proc "gateway" nil) nil proc)) + buffer-read-only last-coding-system-used) ;; Under Windows XP, accept-process-output doesn't return ;; sometimes. So we add an additional timeout. (with-timeout ((or timeout 1)) (if (featurep 'xemacs) - (accept-process-output proc timeout timeout-msecs) - (accept-process-output proc timeout timeout-msecs (and proc t))))) - (tramp-message proc 10 "\n%s" (buffer-string)))) + (accept-process-output p timeout timeout-msecs) + (accept-process-output p timeout timeout-msecs (and proc t)))) + (tramp-message proc 10 "%s %s %s\n%s" + proc (process-status proc) p (buffer-string))))) (defun tramp-check-for-regexp (proc regexp) "Check, whether REGEXP is contained in process buffer of PROC. @@ -3698,11 +3778,11 @@ Example: (tramp-equal-remote \"/ssh::/etc\" \"/<your host name>:/home\") -would yield `t'. On the other hand, the following check results in nil: +would yield t. On the other hand, the following check results in nil: (tramp-equal-remote \"/sudo::/etc\" \"/su::/etc\")" - (and (stringp (file-remote-p file1)) - (stringp (file-remote-p file2)) + (and (tramp-tramp-file-p file1) + (tramp-tramp-file-p file2) (string-equal (file-remote-p file1) (file-remote-p file2)))) ;;;###tramp-autoload @@ -3850,9 +3930,18 @@ be granted." (or result (let ((file-attr - (tramp-get-file-property - vec (tramp-file-name-localname vec) - (concat "file-attributes-" suffix) nil)) + (or + (tramp-get-file-property + vec (tramp-file-name-localname vec) + (concat "file-attributes-" suffix) nil) + (tramp-compat-file-attributes + (tramp-make-tramp-file-name + (tramp-file-name-method vec) + (tramp-file-name-user vec) + (tramp-file-name-host vec) + (tramp-file-name-localname vec) + (tramp-file-name-hop vec)) + (intern suffix)))) (remote-uid (tramp-get-connection-property vec (concat "uid-" suffix) nil)) @@ -3888,10 +3977,9 @@ be granted." (stringp host) (string-match tramp-local-host-regexp host) ;; The method shall be applied to one of the shell file name - ;; handler. `tramp-local-host-p' is also called for "smb" and + ;; handlers. `tramp-local-host-p' is also called for "smb" and ;; alike, where it must fail. - (tramp-get-method-parameter - (tramp-file-name-method vec) 'tramp-login-program) + (tramp-get-method-parameter vec 'tramp-login-program) ;; The local temp directory must be writable for the other user. (file-writable-p (tramp-make-tramp-file-name @@ -3907,18 +3995,19 @@ be granted." (defun tramp-get-remote-tmpdir (vec) "Return directory for temporary files on the remote host identified by VEC." - (with-tramp-connection-property vec "tmpdir" - (let ((dir (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-host vec) - (or - (tramp-get-method-parameter - (tramp-file-name-method vec) 'tramp-tmpdir) - "/tmp")))) - (if (and (file-directory-p dir) (file-writable-p dir)) - dir - (tramp-error vec 'file-error "Directory %s not accessible" dir))))) + (when (file-remote-p (tramp-get-connection-property vec "tmpdir" "")) + ;; Compatibility code: Cached value shall be the local path only. + (tramp-set-connection-property vec "tmpdir" 'undef)) + (let ((dir (tramp-make-tramp-file-name + (tramp-file-name-method vec) + (tramp-file-name-user vec) + (tramp-file-name-host vec) + (or (tramp-get-method-parameter vec 'tramp-tmpdir) "/tmp")))) + (with-tramp-connection-property vec "tmpdir" + (or (and (file-directory-p dir) (file-writable-p dir) + (tramp-file-name-handler 'file-remote-p dir 'localname)) + (tramp-error vec 'file-error "Directory %s not accessible" dir))) + dir)) ;;;###tramp-autoload (defun tramp-make-tramp-temp-file (vec) @@ -3954,6 +4043,48 @@ Return the local name of the temporary file." 'tramp-delete-temp-file-function))) ;;; Auto saving to a special directory: +(defvar auto-save-file-name-transforms) + +(defun tramp-handle-make-auto-save-file-name () + "Like `make-auto-save-file-name' for Tramp files. +Returns a file name in `tramp-auto-save-directory' for autosaving +this file, if that variable is non-nil." + (when (stringp tramp-auto-save-directory) + (setq tramp-auto-save-directory + (expand-file-name tramp-auto-save-directory))) + ;; Create directory. + (unless (or (null tramp-auto-save-directory) + (file-exists-p tramp-auto-save-directory)) + (make-directory tramp-auto-save-directory t)) + + (let ((system-type 'not-windows) + (auto-save-file-name-transforms + (if (and (null tramp-auto-save-directory) + (boundp 'auto-save-file-name-transforms)) + (symbol-value 'auto-save-file-name-transforms))) + (buffer-file-name + (if (null tramp-auto-save-directory) + buffer-file-name + (expand-file-name + (tramp-subst-strs-in-string + '(("_" . "|") + ("/" . "_a") + (":" . "_b") + ("|" . "__") + ("[" . "_l") + ("]" . "_r")) + (buffer-file-name)) + tramp-auto-save-directory)))) + ;; Run plain `make-auto-save-file-name'. There might be an advice when + ;; it is not a magic file name operation (since Emacs 22). + ;; We must deactivate it temporarily. + (if (not (ad-is-active 'make-auto-save-file-name)) + (tramp-run-real-handler 'make-auto-save-file-name nil) + ;; else + (ad-deactivate 'make-auto-save-file-name) + (prog1 + (tramp-run-real-handler 'make-auto-save-file-name nil) + (ad-activate 'make-auto-save-file-name))))) (unless (tramp-exists-file-name-handler 'make-auto-save-file-name) (defadvice make-auto-save-file-name @@ -4016,25 +4147,74 @@ ALIST is of the form ((FROM . TO) ...)." ;;; Compatibility functions section: (defun tramp-call-process - (program &optional infile destination display &rest args) + (vec program &optional infile destination display &rest args) "Calls `call-process' on the local host. -This is needed because for some Emacs flavors Tramp has -defadvised `call-process' to behave like `process-file'. The -Lisp error raised when PROGRAM is nil is trapped also, returning 1. -Furthermore, traces are written with verbosity of 6." - (tramp-message - (vector tramp-current-method tramp-current-user tramp-current-host nil nil) - 6 "%s %s %s" program infile args) - (if (executable-find program) - (apply 'call-process program infile destination display args) - 1)) +It always returns a return code. The Lisp error raised when +PROGRAM is nil is trapped also, returning 1. Furthermore, traces +are written with verbosity of 6." + (let ((v (or vec + (vector tramp-current-method tramp-current-user + tramp-current-host nil nil))) + (destination (if (eq destination t) (current-buffer) destination)) + result) + (tramp-message + v 6 "`%s %s' %s %s" + program (mapconcat 'identity args " ") infile destination) + (condition-case err + (with-temp-buffer + (setq result + (apply + 'call-process program infile (or destination t) display args)) + ;; `result' could also be an error string. + (when (stringp result) + (signal 'file-error (list result))) + (with-current-buffer + (if (bufferp destination) destination (current-buffer)) + (tramp-message v 6 "%d\n%s" result (buffer-string)))) + (error + (setq result 1) + (tramp-message v 6 "%d\n%s" result (error-message-string err)))) + result)) + +(defun tramp-call-process-region + (vec start end program &optional delete buffer display &rest args) + "Calls `call-process-region' on the local host. +It always returns a return code. The Lisp error raised when +PROGRAM is nil is trapped also, returning 1. Furthermore, traces +are written with verbosity of 6." + (let ((v (or vec + (vector tramp-current-method tramp-current-user + tramp-current-host nil nil))) + (buffer (if (eq buffer t) (current-buffer) buffer)) + result) + (tramp-message + v 6 "`%s %s' %s %s %s %s" + program (mapconcat 'identity args " ") start end delete buffer) + (condition-case err + (progn + (setq result + (apply + 'call-process-region + start end program delete buffer display args)) + ;; `result' could also be an error string. + (when (stringp result) + (signal 'file-error (list result))) + (with-current-buffer (if (bufferp buffer) buffer (current-buffer)) + (if (zerop result) + (tramp-message v 6 "%d" result) + (tramp-message v 6 "%d\n%s" result (buffer-string))))) + (error + (setq result 1) + (tramp-message v 6 "%d\n%s" result (error-message-string err)))) + result)) ;;;###tramp-autoload (defun tramp-read-passwd (proc &optional prompt) "Read a password from user (compat function). Consults the auth-source package. Invokes `password-read' if available, `read-passwd' else." - (let* ((key (tramp-make-tramp-file-name + (let* ((case-fold-search t) + (key (tramp-make-tramp-file-name tramp-current-method tramp-current-user tramp-current-host "")) (pw-prompt @@ -4042,47 +4222,66 @@ Invokes `password-read' if available, `read-passwd' else." (with-current-buffer (process-buffer proc) (tramp-check-for-regexp proc tramp-password-prompt-regexp) (format "%s for %s " (capitalize (match-string 1)) key)))) - auth-info auth-passwd) - (with-parsed-tramp-file-name key nil - (prog1 - (or - ;; See if auth-sources contains something useful, if it's - ;; bound. `auth-source-user-or-password' is an obsoleted - ;; function, it has been replaced by `auth-source-search'. - (and (boundp 'auth-sources) - (tramp-get-connection-property v "first-password-request" nil) - ;; Try with Tramp's current method. - (if (fboundp 'auth-source-search) - (setq auth-info - (tramp-compat-funcall - 'auth-source-search - :max 1 - :user (or tramp-current-user t) - :host tramp-current-host - :port tramp-current-method) - auth-passwd (plist-get (nth 0 auth-info) :secret) - auth-passwd (if (functionp auth-passwd) - (funcall auth-passwd) - auth-passwd)) - (tramp-compat-funcall - 'auth-source-user-or-password - "password" tramp-current-host tramp-current-method))) - ;; Try the password cache. - (when (functionp 'password-read) - (unless (tramp-get-connection-property - v "first-password-request" nil) - (tramp-compat-funcall 'password-cache-remove key)) - (let ((password - (tramp-compat-funcall 'password-read pw-prompt key))) - (tramp-compat-funcall 'password-cache-add key password) - password)) - ;; Else, get the password interactively. - (read-passwd pw-prompt)) - (tramp-set-connection-property v "first-password-request" nil))))) + ;; We suspend the timers while reading the password. + (stimers (and (functionp 'with-timeout-suspend) + (tramp-compat-funcall 'with-timeout-suspend))) + auth-info auth-passwd) + + (unwind-protect + (with-parsed-tramp-file-name key nil + (prog1 + (or + ;; See if auth-sources contains something useful, if + ;; it's bound. `auth-source-user-or-password' is an + ;; obsoleted function, it has been replaced by + ;; `auth-source-search'. + (ignore-errors + (and (boundp 'auth-sources) + (tramp-get-connection-property + v "first-password-request" nil) + ;; Try with Tramp's current method. + (if (fboundp 'auth-source-search) + (setq auth-info + (tramp-compat-funcall + 'auth-source-search + :max 1 + :user (or tramp-current-user t) + :host tramp-current-host + :port tramp-current-method) + auth-passwd (plist-get + (nth 0 auth-info) :secret) + auth-passwd (if (functionp auth-passwd) + (funcall auth-passwd) + auth-passwd)) + (tramp-compat-funcall + 'auth-source-user-or-password + "password" tramp-current-host tramp-current-method)))) + ;; Try the password cache. + (when (functionp 'password-read) + (let ((password + (tramp-compat-funcall 'password-read pw-prompt key))) + (tramp-compat-funcall 'password-cache-add key password) + password)) + ;; Else, get the password interactively. + (read-passwd pw-prompt)) + (tramp-set-connection-property v "first-password-request" nil))) + ;; Reenable the timers. + (and (functionp 'with-timeout-unsuspend) + (tramp-compat-funcall 'with-timeout-unsuspend stimers))))) ;;;###tramp-autoload (defun tramp-clear-passwd (vec) "Clear password cache for connection related to VEC." + (let ((hop (tramp-file-name-hop vec))) + (when hop + ;; Clear also the passwords of the hops. + (tramp-clear-passwd + (tramp-dissect-file-name + (concat + tramp-prefix-format + (tramp-compat-replace-regexp-in-string + (concat tramp-postfix-hop-regexp "$") + tramp-postfix-host-format hop)))))) (tramp-compat-funcall 'password-cache-remove (tramp-make-tramp-file-name @@ -4103,26 +4302,6 @@ Invokes `password-read' if available, `read-passwd' else." ("oct" . 10) ("nov" . 11) ("dec" . 12)) "Alist mapping month names to integers.") -;; FIXME: Shouldn't this also look at any subseconds parts of T1 and T2? -;;;###tramp-autoload -(defun tramp-time-less-p (t1 t2) - "Say whether time value T1 is less than time value T2." - (unless t1 (setq t1 '(0 0))) - (unless t2 (setq t2 '(0 0))) - (or (< (car t1) (car t2)) - (and (= (car t1) (car t2)) - (< (nth 1 t1) (nth 1 t2))))) - -;; FIXME: Shouldn't this also look at any subseconds parts of T1 and T2? -(defun tramp-time-subtract (t1 t2) - "Subtract two time values. -Return the difference in the format of a time value." - (unless t1 (setq t1 '(0 0))) - (unless t2 (setq t2 '(0 0))) - (let ((borrow (< (cadr t1) (cadr t2)))) - (list (- (car t1) (car t2) (if borrow 1 0)) - (- (+ (if borrow 65536 0) (cadr t1)) (cadr t2))))) - ;;;###tramp-autoload (defun tramp-time-diff (t1 t2) "Return the difference between the two times, in seconds. @@ -4141,7 +4320,7 @@ T1 and T2 are time values (as returned by `current-time' for example)." (if (< (length t1) 3) (append t1 '(0)) t1) (if (< (length t2) 3) (append t2 '(0)) t2))) (t - (let ((time (tramp-time-subtract t1 t2))) + (let ((time (time-subtract t1 t2))) (+ (* (car time) 65536.0) (cadr time) (/ (or (nth 2 time) 0) 1000000.0)))))) @@ -4163,7 +4342,7 @@ T1 and T2 are time values (as returned by `current-time' for example)." ;; This function should produce a string which is grokked by a Unix ;; shell, even if the Emacs is running on Windows. Since this is the ;; kludges section, we bind `system-type' in such a way that -;; `shell-quote-arguments' behaves as if on Unix. +;; `shell-quote-argument' behaves as if on Unix. ;; ;; Thanks to Mario DeWeerd for the hint that it is sufficient for this ;; function to work with Bourne-like shells. @@ -4194,7 +4373,7 @@ Only works for Bourne-like shells." (defun tramp-eshell-directory-change () "Set `eshell-path-env' to $PATH of the host related to `default-directory'." (setq eshell-path-env - (if (file-remote-p default-directory) + (if (tramp-tramp-file-p default-directory) (with-parsed-tramp-file-name default-directory nil (mapconcat 'identity @@ -4236,8 +4415,6 @@ Only works for Bourne-like shells." ;;; TODO: -;; * Rewrite `tramp-shell-quote-argument' to abstain from using -;; `shell-quote-argument'. ;; * In Emacs 21, `insert-directory' shows total number of bytes used ;; by the files in that directory. Add this here. ;; * Avoid screen blanking when hitting `g' in dired. (Eli Tziperman) @@ -4254,11 +4431,6 @@ Only works for Bourne-like shells." ;; tramp-server-local-variable-alist) to define any such variables ;; that they need to, which would then be let bound as appropriate ;; in tramp functions. (Jason Rumney) -;; * IMHO, it's a drawback that currently Tramp doesn't support -;; Unicode in Dired file names by default. Is it possible to -;; improve Tramp to set LC_ALL to "C" only for commands where Tramp -;; expects English? Or just to set LC_MESSAGES to "C" if Tramp -;; expects only English messages? (Juri Linkov) ;; * Make shadowfile.el grok Tramp filenames. (Bug#4526, Bug#4846) ;; * I was wondering if it would be possible to use tramp even if I'm ;; actually using sshfs. But when I launch a command I would like diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index 0e54cd60d98..5c42f3a828a 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -1,7 +1,7 @@ ;;; trampver.el --- Transparent Remote Access, Multiple Protocol ;;; lisp/trampver.el. Generated from trampver.el.in by configure. -;; Copyright (C) 2003-2013 Free Software Foundation, Inc. +;; Copyright (C) 2003-2015 Free Software Foundation, Inc. ;; Author: Kai Großjohann <kai.grossjohann@gmx.net> ;; Keywords: comm, processes @@ -24,27 +24,45 @@ ;;; Code: -;; In the Tramp CVS repository, the version number and the bug report +;; In the Tramp GIT repository, the version number and the bug report ;; address are auto-frobbed from configure.ac, so you should edit that ;; file and run "autoconf && ./configure" to change them. (X)Emacs ;; version check is defined in macro AC_EMACS_INFO of aclocal.m4; ;; should be changed only there. ;;;###tramp-autoload -(defconst tramp-version "2.2.8-pre" +(defconst tramp-version "2.2.13-pre" "This version of Tramp.") ;;;###tramp-autoload (defconst tramp-bug-report-address "tramp-devel@gnu.org" "Email address to send bug reports to.") +;; `locate-dominating-file' does not exist in XEmacs. But it is not used here. +(autoload 'locate-dominating-file "files") +(autoload 'tramp-compat-replace-regexp-in-string "tramp-compat") + +(defun tramp-repository-get-version () + "Try to return as a string the repository revision of the Tramp sources." + (unless (featurep 'xemacs) + (let ((dir (locate-dominating-file (locate-library "tramp") ".git"))) + (when dir + (with-temp-buffer + (let ((default-directory (file-name-as-directory dir))) + (and (zerop + (ignore-errors + (call-process "git" nil '(t nil) nil "rev-parse" "HEAD"))) + (not (zerop (buffer-size))) + (tramp-compat-replace-regexp-in-string + "\n" "" (buffer-string))))))))) + ;; Check for (X)Emacs version. (let ((x (if (or (>= emacs-major-version 22) (and (featurep 'xemacs) (= emacs-major-version 21) (>= emacs-minor-version 4))) "ok" - (format "Tramp 2.2.8-pre is not fit for %s" + (format "Tramp 2.2.13-pre is not fit for %s" (when (string-match "^.*$" (emacs-version)) (match-string 0 (emacs-version))))))) (unless (string-match "\\`ok\\'" x) (error "%s" x))) diff --git a/lisp/net/webjump.el b/lisp/net/webjump.el index a7db6d0a73b..7cb017f39a3 100644 --- a/lisp/net/webjump.el +++ b/lisp/net/webjump.el @@ -1,6 +1,6 @@ ;;; webjump.el --- programmable Web hotlist -;; Copyright (C) 1996-1997, 2001-2013 Free Software Foundation, Inc. +;; Copyright (C) 1996-1997, 2001-2015 Free Software Foundation, Inc. ;; Author: Neil W. Van Dyke <nwv@acm.org> ;; Created: 09-Aug-1996 diff --git a/lisp/net/zeroconf.el b/lisp/net/zeroconf.el index 2160443c395..794a4676a5e 100644 --- a/lisp/net/zeroconf.el +++ b/lisp/net/zeroconf.el @@ -1,6 +1,6 @@ ;;; zeroconf.el --- Service browser using Avahi. -;; Copyright (C) 2008-2013 Free Software Foundation, Inc. +;; Copyright (C) 2008-2015 Free Software Foundation, Inc. ;; Author: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, hardware @@ -197,7 +197,7 @@ The key of an entry is the concatenation of the service name and service type of a discovered service. The value is the service itself. The format of a service is - \(INTERFACE PROTOCOL NAME TYPE DOMAIN FLAGS\) + \(INTERFACE PROTOCOL NAME TYPE DOMAIN FLAGS) The INTERFACE is a number, which represents the network interface the service is located at. The corresponding network interface @@ -233,7 +233,7 @@ The key of an entry is the concatenation of the service name and service type of a resolved service. The value is the service itself. The format of a service is - \(INTERFACE PROTOCOL NAME TYPE DOMAIN HOST APROTOCOL ADDRESS PORT TXT FLAGS\) + (INTERFACE PROTOCOL NAME TYPE DOMAIN HOST APROTOCOL ADDRESS PORT TXT FLAGS) INTERFACE, PROTOCOL, NAME, TYPE, DOMAIN and FLAGS have the same meaning as in `zeroconf-services-hash'. @@ -275,7 +275,7 @@ supported keys depend on the service type.") "Returns all discovered Avahi services for a given service type TYPE. The service type is one of the returned values of `zeroconf-list-service-types'. The return value is a list -\(SERVICE1 SERVICE2 ...\). See `zeroconf-services-hash' for the +\(SERVICE1 SERVICE2 ...). See `zeroconf-services-hash' for the format of SERVICE." (let (result) (maphash @@ -385,7 +385,7 @@ type used when registering FUNCTION." NAME must be a string. The service must be of service type TYPE. The resulting list has the format - \(INTERFACE PROTOCOL NAME TYPE DOMAIN FLAGS\)." + (INTERFACE PROTOCOL NAME TYPE DOMAIN FLAGS)." ;; Due to the service browser, all known services are kept in ;; `zeroconf-services-hash'. (gethash (concat name "/" type) zeroconf-services-hash nil)) @@ -395,7 +395,7 @@ TYPE. The resulting list has the format NAME must be a string. The service must be of service type TYPE. The resulting list has the format - \(INTERFACE PROTOCOL NAME TYPE DOMAIN HOST APROTOCOL ADDRESS PORT TXT FLAGS\)." + (INTERFACE PROTOCOL NAME TYPE DOMAIN HOST APROTOCOL ADDRESS PORT TXT FLAGS)." (let* ((name (zeroconf-service-name service)) (type (zeroconf-service-type service)) (key (concat name "/" type))) |